PREGSM1.inc
References to this file elsewhere.
1 SUBROUTINE PREGSM1(PS,GT,GU,GV,GQ,PSB,GTB,GUB,GVB,GQB,
2 & IMAXE,JMAXE,ISST,JSST,MAXJZ,IVAR,
3 & IMAX,JMAX,KMAX,IDIM,JDIM,MEND1,NEMD1,JEND1,
4 & ISNW,JSNW,JMAXHF,MNWAV,IMX) !shc start
5 INTEGER IDATE(5), IDGES(5), IDSST(5)
6 CHARACTER*8 FILE, MODEL, RESL
7 CHARACTER*80 CINF(10)
8 CHARACTER*4 TYPE, EXPR, KTUNIT, NPROD, NPROM, VCODD, VCODM
9 CHARACTER*4 LEVEL, ELEM
10 CHARACTER*32 TITLE
11 CHARACTER*16 UNIT
12 CHARACTER*8 MDLINF(4)
13 ! modified by shc p1 start
14 CHARACTER*80 CINF_X(10),CINF_temp
15 CHARACTER*4 VCODD_X, VCODM_X
16 ! modified by shc p1 end
17 REAL DTHPRO(7)
18 INTEGER ITYP(2)
19 CHARACTER*48 LABEL
20 INTEGER JTINF(2)
21 CHARACTER*10 FROMUNPACK
22 INTEGER IUNPACK
23 C
24 DIMENSION A(KMAX+1), B(KMAX+1), AAM(KMAX+1), BBM(KMAX+1)
25 DIMENSION AGD(KMAX+1), BGD(KMAX+1), AGM(KMAX+1), BGM(KMAX+1)
26 DIMENSION GPHIS(IMAX*JMAX)
27 REAL, DIMENSION(IMAX,JMAX) :: GAU
28 DIMENSION PS (IMAX,JMAX), GRH (IMAX,JMAX,KMAX), !shc
29 1 GZ (IMAX,JMAX,KMAX), GT (IMAX,JMAX,KMAX),
30 2 GU (IMAX,JMAX,KMAX), GV (IMAX,JMAX,KMAX),
31 3 GQ (IMAX,JMAX,KMAX), AGT (IMAX,JMAX,KMAX),
32 4 GCWC(IMAX,JMAX,KMAX), GCVR(IMAX,JMAX,KMAX),
33 5 GUMB(IMAX,JMAX,KMAX),
34 6 GSST(IMAX,JMAX) , GSNW(IMAX,JMAX)
35 DIMENSION PSB (IMAX,JMAX), GRHB(IMAX,JMAX,KMAX), !shc start
36 1 GQB (IMAX,JMAX,KMAX), GTB (IMAX,JMAX,KMAX),
37 2 GUB (IMAX,JMAX,KMAX), GVB (IMAX,JMAX,KMAX) !shc end
38
39 DIMENSION VLG(IMAX,JMAX,KMAX)
40 C DIMENSION WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX),
41 REAL * 8 WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX)
42 DIMENSION WRK3(IMAX,JMAX,KMAX), WRK4(IMAX,JMAX,KMAX),
43 2 WRK5(IMAX,JMAX,KMAX), WRK6(IMAX,JMAX,KMAX)
44 CHARACTER*4 ALVL
45 !modified by shc I2 start
46 c INTEGER*2 I2(IDIM*JDIM) !shc-rizvi
47 INTEGER I2(IDIM*JDIM/2) !shc-rizvi
48 !modified by shc I2 end
49 REAL*8 WRK(IDIM,JDIM)
50 DIMENSION SSTA(ISST*JSST), SEWA(ISNW,JSNW)
51 DIMENSION COLRAD(JMAX), DY(JMAX), LY(JMAX)
52 DIMENSION WORK(362,182),DP(4,IMAX,JMAX)
53 INTEGER*2 IP(2,IMAX,JMAX)
54 REAL*8 GAUL(JMAX),GAUW(JMAX),COCOT(JMAX)
55 COMMON/CTETEN/TABLE(25000)
56 COMMON/DTETEN/DTABLE(25000)
57 REAL*8 TABLE,DTABLE,RGSA,G
58 real rdum (imax,jmax,kmax) !shcimsi
59 !modified by shc AB start
60 INTEGER MMM0(5)
61 !modified by shc AB end
62 DIMENSION RLAT(MAXJZ), ZDAT(MAXJZ,KMAX)
63 C
64 NAMELIST /NAMFIL/ NALFL,NVPFL,NGSFL,NSSTFL,NSNWFL,NINFL,
65 1 KTLAG,IDCHCK,NDIGFL,NTPFL,NALOT,NRSFL
66 C NAMELIST /HEADIN/ TYPE,FILE,KTUNIT,IDTYPE,
67 C 1 IBACK,NNSP
68 C------------------------------------------------------------------------
69 C NALFL : 3DOI INPUT FILE
70 C NVPFL : VERTIAL LEVEL DEF. FILE
71 C NTPFL : TOPO FILE
72 C NALOT : 3DOI INPUT SAVE FILE
73 C NRSFL : UNPACK INPUT FILE
74 C------------------------------------------------------------------------
75 NAMELIST /NAMVER/ MODEL, RESL, EXPR, CINF
76 C
77 DATA RHMIN/1.0E-3/
78 DATA GRAV,ER,GASR,GAMMA/9.80665,6371.E3,287.04,0.0050/
79 DATA TLAPS,QCONS,QMIN,KST,ITERMX/2.0E-3,2.5E-6,1.0E-10,10,3/
80 C
81 DATA NALFL ,NGSFL ,NSSTFL,NSNWFL,NINFL ,NVPFL ,NALOT,NRSFL
82 1 / 1, 2, -1, -1, 11, 21, 12, -1/
83 DATA KTLAG / 6/
84 DATA IDCHCK/ 1/
85 !modified by shc AB start
86 c The definition A and B by 'DATA' was removed
87 !modified by shc AB end
88 !modified by shc AB start
89 READ(115) MMM0,MMM1,MMM2,FFF1,MMM3,MMM4,
90 1 (A(K),K=1,MMM4),(B(K),K=1,MMM4)
91 A(KMAX+1)=0.0; B(KMAX+1)=0.0
92 !modified by shc AB end
93 C
94 C =================================================================
95 C >>> READ ANAL TIME <<<
96 C =================================================================
97 READ(94,'(I4,3I2)') (IDATE(I),I=1,4)
98 IDATE(5)=0
99 C =================================================================
100 C >>> NAMELIST (NAMFIL) <<<
101 C =================================================================
102 READ(95,NAMFIL)
103 c READ(95,HEADIN)
104 WRITE(6,NAMFIL)
105 c WRITE(6,HEADIN)
106 !modified by shc p1 start
107 LARHM=20
108 !modified by shc p1 end
109 C =================================================================
110 C >>> Select Input Source <<<
111 C =================================================================
112 !shc-wei start
113 c CALL GETENV('FROMUNPACK',FROMUNPACK)
114 c IF (LEN_TRIM(FROMUNPACK).EQ.0) THEN
115 c IUNPACK=0
116 c ELSE
117 c READ(FROMUNPACK,'(I1)') IUNPACK
118 c END IF
119 c WRITE(6,*)'IUNPACK=',IUNPACK
120 !shc-wei end
121 C =================================================================
122 C >>> GENERATE GAUSSIAN LATITUDES <<<
123 C =================================================================
124 CALL GAUSS(GAUL,GAUW,JMAX)
125 DO 800 J=1,JMAX
126 COLRAD(J)=ACOS(GAUL(J))
127 800 CONTINUE
128 CALL ZMNLAT( RLAT, MAXJZ, COLRAD, JMAX )
129 C
130 C =================================================================
131 C >>> TETEN <<<
132 C =================================================================
133 ICE = 1
134 CALL TETEN(ICE)
135 C =================================================================
136 C >>> READ TOPO FILE
137 C =================================================================
138 NTPFL = 3
139 c go to 33333 ! shc For T63 only
140 IF (NTPFL.GT.0) THEN
141 READ(NTPFL)NWV,DUM,IGRD,JGRD
142 IF ((IGRD.NE.IMAX).OR.(JGRD.NE.JMAX)) THEN
143 WRITE(*,*)' TOPO DIM DOES NOT MATCH'
144 WRITE(*,*)'IMAX=',IMAX,' IGRD=',IGRD
145 WRITE(*,*)'JMAX=',JMAX,' JGRD=',JGRD
146 STOP 9988
147 END IF
148 READ(NTPFL)
149 READ(NTPFL)
150 READ(NTPFL)GPHIS
151 WRITE(*,*)'GRID DISTANCE=',DUM
152 END IF
153 C---------------------------------------------------------------------
154 C +++ CONVERT LAT/LON to GAUSS
155 C---------------------------------------------------------------------
156 33333 continue
157 c READ(NTPFL,'(10f10.3)')GPHIS !shc For T63 only
158 C !shc start
159 C =================================================================
160 C >>> PS, TEMP, Q -> RH
161 C =================================================================
162 CALL RELHUM
163 I (GT ,GQ ,PS ,IMAX,JMAX,KMAX,A,B,
164 O GRH)
165 CALL RELHUM
166 I (GTB ,GQB ,PSB ,IMAX,JMAX,KMAX,A,B,
167 O GRHB) !shc end
168 PIHF = 3.141593*0.5 !shc start
169 DO 3739 K = 1,KMAX
170 DO 3738 J = 1,JMAX
171 DO 3737 I = 1,IMAX
172 AANAL = GRH(I,J,K)-GRHB(I,J,K) !shc end
173 AGES = GRHB(I,J,K) !shc start
174 IF ( AGES.LE.0.0 .AND. AANAL.LE.0.0 ) THEN
175 AANAL = 1.0E-6 ! \214\270\202\351\227]\222n\202\252\202\310\202\242
176 ELSEIF( AGES.GE.1.0 .AND. AANAL.GE.0.0 ) THEN
177 AANAL = 1.0 ! \221\235\202\246\202\351\227]\222n\202\252\202\310\202\242
178 ELSE
179 IF( AANAL.GT.0.0 ) THEN
180 RES = 1.0-AGES ! \213\226\227e\227\312
181 ELSE !shc end
182 RES = -AGES !shc start
183 ENDIF
184 IF( ABS(AANAL).LE.ABS(RES*0.5) ) THEN ! \224\274\225\252\210\310\211\272
185 AANAL = AGES+AANAL ! \202\273\202\314\202\334\202\334
186 ELSE
187 AA = RES/PIHF*0.5 !shc end
188 XN = AANAL-RES*0.5 !shc start
189 AANAL = AGES + 0.5*RES + AA*ATAN(XN/AA)
190 ENDIF
191 ENDIF
192 AANAL = MAX( AANAL, 1.0E-6 ) ! \215\305\217I\222\262\220\256
193 AANAL = MIN( AANAL, 1.0E0 )
194 GRH(I,J,K) = AANAL
195 3737 CONTINUE
196 3738 CONTINUE
197 3739 CONTINUE !shc end
198
199 C =================================================================
200 C >>> PS, TEMP, Q -> Z
201 C =================================================================
202 RGAS = 287.04
203 G = 9.80665
204 CALL GPLHGT
205 I (PS,GT,GQ,GPHIS,IMAX,JMAX,KMAX,RGAS,G,A,B,
206 I 1,JMAX,
207 O GZ)
208
209 CLSW do k=1,22,3
210 CLSW do j=1,jmax
211 CLSW write(99,FMT='(10F12.5,1x)') (GZ(I,J,K),I=1,IMAX)
212 CLSW enddo
213 CLSW enddo
214 C ==================================================================
215 C >>> SAVE INPUT DATA
216 C ==================================================================
217 IF (NALOT.GT.0) THEN
218 WRITE(NALOT)PS
219 WRITE(NALOT)GZ
220 WRITE(NALOT)GU
221 WRITE(NALOT)GV
222 WRITE(NALOT)GQ
223 WRITE(NALOT)GT
224 END IF
225 Crizvi ELSE ! START WITH UNPACK FILE
226 Crizvi LARHM=20
227 Crizvi READ(NRSFL)IDATE
228 Crizvi READ(NRSFL)PS
229 Crizvi READ(NRSFL)GZ
230 Crizvi READ(NRSFL)GU
231 Crizvi READ(NRSFL)GV
232 Crizvi READ(NRSFL)GQ
233 Crizvi READ(NRSFL)AGT
234 Crizvi
235 Crizvi END IF ! READ ANAL FINISH
236 print*,' Gaussian lats data size ',IMAX, JMAX, KMAX
237 write(661,'(10f10.3)')PS
238 write(661,'(10f10.3)')GU
239 write(661,'(10f10.3)')GV
240 write(661,'(10f10.3)')GT
241 write(661,'(10f10.3)')GQ
242
243 CLSW write(99,*) ' Gauss GT'
244 CLSW do k=1,2
245 CLSW do j=1,jmax
246 CLSW write(99,FMT='(10F12.5,1x)') (GT(I,J,k),I=1,IMAX)
247 CLSW enddo
248 CLSW enddo
249 C---------------------------------------------------------------------
250 C DO J = 1, JMAX
251 C write(99,FMT='(10F12.5,1x)') (GAU(I,J),I=1,IMAX)
252 C ENDDO
253
254 1000 CONTINUE
255
256 C =================================================================
257 C >>> NAMELIST (NAMVER) <<<
258 C =================================================================
259 CINF(1)=' ';CINF(2)=' ';CINF(3)=' ';CINF(4)=' ';CINF(5)=' '
260 CINF(6)=' ';CINF(7)=' ';CINF(8)=' ';CINF(9)=' ';CINF(10)=' '
261 READ(95,NAMVER)
262 WRITE(6,NAMVER)
263 C =================================================================
264 IF(NGSFL.GE.0) THEN
265 CALL REDGES
266 I(NGSFL ,IMAX ,JMAX ,KMAX ,KTLAG ,IDATE ,IDCHCK,
267 O IDGES ,AGD ,BGD ,AGM ,BGM ,GCWC ,GCVR ,GUMB ,
268 W I2 ,IDSST )
269 ENDIF
270 !modified by shc ZT start
271 goto 7700
272 !modified by shc ZT end
273 C =================================================================
274 C >>> Z -> TV <<<
275 C =================================================================
276 C CALL CTIME( 4, 'ZE2TVE ' )
277 C >>> GT IS TV (OUTPUT)
278 IF (NTPFL.LT.0) THEN
279 CALL GH2TV(GZ, GT, PS, GPHIS, A, B,
280 1 IMAX , JMAX , KMAX ,WRK1 , WRK2 , WRK3 , WRK4)
281 ELSE
282 CALL ZE2TVE( GZ , GT , PS , A , B ,
283 I IMAX , JMAX , KMAX ,
284 W VLG , WRK1 , WRK2 , WRK3 , WRK4 , WRK5 ,
285 W WRK6 )
286 C
287 CLSW write(99,*) ' Z->TV'
288 CLSW do k=1,2
289 CLSW do j=1,jmax
290 CLSW write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX)
291 CLSW enddo
292 CLSW enddo
293 END IF
294 CLSW CALL ZMNT( ZDAT, MAXJZ, KMAX, GT , IMAX, JMAX )
295 CLSW CALL OUTZ( ZDAT, MAXJZ, KMAX, 'TV ',
296 CLSW 1 'TV ', 'K ',
297 CLSW 2 0, RLAT, 'KMAX' )
298
299 C =================================================================
300 C >>> RH, TV -> Q, T <<<
301 C =================================================================
302 IDX=1
303 LARHM=20 !shc start
304 DO K=1,LARHM-1
305 DO I=1,IMAX
306 DO J=1,JMAX
307 GQ(I,J,K)=GRH(I,J,K)
308 ENDDO
309 ENDDO
310 ENDDO !shc end
311 CALL CRH2SHA
312 I(IMAX*JMAX, KMAX, PS, A, B, GRAV,GASR,TLAPS,QCONS,QMIN,KST,ITERMX,
313 I IDX, LARHM,
314 O GQ, GT)
315 C write(99,*) ' after RH, TV -> Q, T'
316 C do k=1,2
317 C do j=1,jmax
318 C write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX)
319 C enddo
320 C enddo
321 !modified by shc ZT start
322 7700 continue
323 !modified by shc ZT end
324
325 !modified by shc q0 start
326 DO I=1,IMAX
327 DO J=1,JMAX
328 DO K=1,KMAX
329 IF (GQ(I,J,K).LT.0.00) GQ(I,J,K)=1.E-06
330 ENDDO
331 ENDDO
332 ENDDO
333 print *, 'shcimsi q0=',1.E-06
334 !modified by shc q0 end
335
336 !modified by shc p1 start
337 NANFL=151
338 KT=0
339 DO i=1,80
340 CINF_temp(i:i)=' '
341 ENDDO
342 DO j=1,10
343 CINF_X(j)=CINF_temp
344 ENDDO
345 VCODD_X=' '
346 VCODM_X=' '
347 CALL WRTHED
348 I(NANFL ,
349 I 'GVS1',IDATE ,'ANALETA ','GANL9603','T213L30L',
350 I 'R03 ','HOUR',1 ,0 ,0 ,
351 I IMAX ,JMAX ,'GAUS', 0.0 , 0.0,
352 I 0.0 ,0.0, 0.0 ,0.0 ,
353 I VCODD_X,KMAX ,A ,B ,
354 I IMAX ,JMAX ,'GAUS', 0.0 , 0.0,
355 I 0.0 ,0.0, 0.0 ,0.0 ,
356 I VCODM_X,KMAX ,A ,B ,
357 I CINF_X )
358
359 GPHIS(:)=GPHIS(:)/G
360 CALL MOVERD(GPHIS, WRK, IMAX*JMAX)
361 CALL WRTDAT
362 1(NANFL , IDATE , KT , 'SURF', 'TOPO',
363 2 'GEOPOTENTIAL HEIGHT ', 'M ',
364 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
365
366 CALL MOVERD(PS, WRK, IMAX*JMAX)
367 CALL WRTDAT
368 1(NANFL , IDATE , KT , 'SURF', 'P ',
369 2 'SURFACE PRESSURE ', 'HPA ',
370 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
371
372 CALL MOVERD(GU(1,1,1), WRK, IMAX*JMAX)
373 CALL WRTDAT
374 1(NANFL , IDATE , KT , 'SURF', 'U ',
375 2 'SURFACE U ', 'M/S ',
376 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
377
378 CALL MOVERD(GV(1,1,1), WRK, IMAX*JMAX)
379 CALL WRTDAT
380 1(NANFL , IDATE , KT , 'SURF', 'V ',
381 2 'SURFACE V ', 'M/S ',
382 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
383
384 CALL MOVERD(GT(1,1,1), WRK, IMAX*JMAX)
385 CALL WRTDAT
386 1(NANFL , IDATE , KT , 'SURF', 'T ',
387 2 'SURFACE T ', 'K ',
388 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
389
390 CALL MOVERD(GRH(1,1,1), WRK, IMAX*JMAX)
391 CALL WRTDAT
392 1(NANFL , IDATE , KT , 'SURF', 'RH ',
393 2 'SURFACE RELATIVE HUMIDITY ', '0-1 ',
394 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
395
396 DO K=1,KMAX
397 CALL MOVERD(GU(1,1,K), WRK, IMAX*JMAX)
398 WRITE(ALVL(1:4), '(I4)') K
399 CALL WRTDAT
400 1 (NANFL , IDATE , KT , ALVL, 'U ',
401 2 'U ', 'M/S ',
402 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
403 ENDDO
404
405 DO K=1,KMAX
406 CALL MOVERD(GV(1,1,K), WRK, IMAX*JMAX)
407 WRITE(ALVL(1:4), '(I4)') K
408 CALL WRTDAT
409 1 (NANFL , IDATE , KT , ALVL, 'V ',
410 2 'V ', 'M/S ',
411 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
412 ENDDO
413
414 DO K=1,KMAX
415 CALL MOVERD(GZ(1,1,K), WRK, IMAX*JMAX)
416 WRITE(ALVL(1:4), '(I4)') K
417 CALL WRTDAT
418 1 (NANFL , IDATE , KT , ALVL, 'Z ',
419 2 'GEOPOTENTIAL HEIGHT ', 'M ',
420 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
421 ENDDO
422
423 DO K=1,KMAX
424 CALL MOVERD(GT(1,1,K), WRK, IMAX*JMAX)
425 WRITE(ALVL(1:4), '(I4)') K
426 CALL WRTDAT
427 1 (NANFL , IDATE , KT , ALVL, 'T ',
428 2 'TEMPERATURE ', 'K ',
429 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
430 ENDDO
431
432 DO K=1, LARHM-1
433 CALL MOVERD(GRH(1,1,K), WRK, IMAX*JMAX)
434 WRITE(ALVL(1:4), '(I4)') K
435 CALL WRTDAT
436 1 (NANFL , IDATE , KT , ALVL, 'RH ',
437 2 'RELATIVE HUMIDITY ', '0-1 ',
438 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
439 ENDDO
440
441 DO K=LARHM,KMAX
442 CALL MOVERD(GQ(1,1,K), WRK, IMAX*JMAX)
443 WRITE(ALVL(1:4), '(I4)') K
444 CALL WRTDAT
445 1 (NANFL , IDATE , KT , ALVL, 'Q ',
446 2 'SPECIFIC HUMIDITY ', 'KG/KG ',
447 3 0 , 0 ,WRK , IMAX , JMAX , I2 )
448 ENDDO
449 WRITE(NANFL) IDATE,KT,0,' ',' '
450 !modified by shc p1 end
451 C *****************************************************************
452 C >>> OUTPUT INITIAL VALUE <<<
453 C *****************************************************************
454 C =================================================================
455 C >>> HEADER <<<
456 C =================================================================
457 CALL WRTHED
458 I(NINFL ,
459 I 'GVS1',IDATE ,'INITETA ',MODEL, RESL,
460 I EXPR ,'HOUR',1 ,0 ,0 ,
461 I IMAX ,JMAX ,'GAUS',360.0/IMAX, REAL(JMAX),
462 I 1.0 ,(JMAX+1)/2.0, 0.0 ,0.0 ,
463 I 'ETA ',KMAX ,A ,B ,
464 I IMAX ,JMAX ,'GAUS',360.0/IMAX, REAL(JMAX),
465 I 1.0 ,(JMAX+1)/2.0, 0.0 ,0.0 ,
466 I 'ETA ',KMAX ,A ,B ,
467 I CINF )
468 C
469 C =================================================================
470 C >>> PS <<<
471 C =================================================================
472 CALL MOVERD(PS, WRK, IMAX*JMAX)
473 CALL WRTDAT
474 1(NINFL , IDATE , -1 , 'SURF', 'P ',
475 2 'P ', 'HPA ',
476 3 0 , 0 , WRK , IMAX , JMAX , I2 )
477 C
478 C =================================================================
479 C >>> U, V <<<
480 C =================================================================
481 DO 9030 K=1,KMAX
482 CALL MOVERD(GU(1,1,K), WRK, IMAX*JMAX)
483 WRITE(ALVL(1:4), '(I4)') K
484 CALL WRTDAT
485 1 (NINFL , IDATE , -1 , ALVL , 'U ',
486 2 'U ', 'M/S ',
487 3 0 , 0 , WRK , IMAX , JMAX , I2 )
488 9030 CONTINUE
489 DO 9040 K=1,KMAX
490 CALL MOVERD(GV(1,1,K), WRK, IMAX*JMAX)
491 WRITE(ALVL(1:4), '(I4)') K
492 CALL WRTDAT
493 1 (NINFL , IDATE , -1 , ALVL , 'V ',
494 2 'V ', 'M/S ',
495 3 0 , 0 , WRK , IMAX , JMAX , I2 )
496 9040 CONTINUE
497 C =================================================================
498 C >>> T, Q <<<
499 C =================================================================
500 DO 9010 K=1,KMAX
501 CALL MOVERD(GT(1,1,K), WRK, IMAX*JMAX)
502 WRITE(ALVL(1:4), '(I4)') K
503 CALL WRTDAT
504 1 (NINFL , IDATE , -1 , ALVL , 'T ',
505 2 'T ', 'K ',
506 3 0 , 0 , WRK , IMAX , JMAX , I2 )
507 9010 CONTINUE
508 DO 9020 K=1,KMAX
509 CALL MOVERD(GQ(1,1,K), WRK, IMAX*JMAX)
510 WRITE(ALVL(1:4), '(I4)') K
511 CALL WRTDAT
512 1 (NINFL , IDATE , -1 , ALVL , 'Q ',
513 2 'Q ', 'KG/KG ',
514 3 0 , 0 , WRK , IMAX , JMAX , I2 )
515 9020 CONTINUE
516 C =================================================================
517 C >>> SAVE INPUT FIELD FOR DIAG.
518 C =================================================================
519 IF (NDIGFL.GT.0) THEN
520 WRITE(NDIGFL)GT
521 WRITE(NDIGFL)GQ
522 END IF
523 C
524 C =================================================================
525 C >>> CWC, CVR <<<
526 C =================================================================
527 IF(NGSFL.GT.0) THEN
528 DO 9050 K=1,KMAX
529 CALL MOVERD(GCWC(1,1,K), WRK, IMAX*JMAX)
530 WRITE(ALVL(1:4), '(I4)') K
531 CALL WRTDAT
532 1 (NINFL , IDATE , -1 , ALVL , 'CWC ',
533 2 'CLOUD WATER CONTENT ', 'KG/KG ',
534 3 0 , 0 , WRK , IMAX , JMAX , I2 )
535 9050 CONTINUE
536 DO 9060 K=1,KMAX
537 CALL MOVERD(GCVR(1,1,K), WRK, IMAX*JMAX)
538 WRITE(ALVL(1:4), '(I4)') K
539 CALL WRTDAT
540 1 (NINFL , IDATE , -1 , ALVL , 'CVR ',
541 2 'CLOUD COVER ', '- ',
542 3 0 , 0 , WRK , IMAX , JMAX , I2 )
543 9060 CONTINUE
544 C
545 C =================================================================
546 C >>> UMB <<<
547 C =================================================================
548 DO 9070 K=1,KMAX
549 CALL MOVERD(GUMB(1,1,K), WRK, IMAX*JMAX)
550 WRITE(ALVL(1:4), '(I4)') K
551 CALL WRTDAT
552 1 (NINFL , IDATE , -1 , ALVL , 'UMB ',
553 2 'UPWARD MASS FLUX AT CLOUD BASE ', 'KG/S/M**2 ',
554 3 0 , 0 , WRK , IMAX , JMAX , I2 )
555 9070 CONTINUE
556 END IF !NGSFL>0
557 C
558 C *****************************************************************
559 C >>> SST ANOMALY <<<
560 C *****************************************************************
561 IF( NSSTFL.NE.-1 ) THEN
562 CALL GETTYP(NSSTFL,IOTYP)
563 C
564 IF(IOTYP.EQ.1) THEN
565 C CALL GVDFIR(NSSTFL,
566 C 1 IDSST,IBACK,IM,JM,MDLINF,DTHPRO,CINF,ITYP,IRTN)
567 C WRITE(6,*) 'GVDFIR:IRTN=',IRTN
568 C CALL GVDFNR(NSSTFL,IDSST,0,'SURF','SSTA',
569 C 1 LABEL,JTINF,SSTA,IRTN)
570 C WRITE(6,*) 'GVDFNR:IRTN=',IRTN
571 WRITE(*,*)' UNKNOWN IOTYP:1'
572 STOP 9999
573 ELSE IF(IOTYP.EQ.3) THEN
574 C =================================================================
575 C >>> HEADER <<<
576 C =================================================================
577 CALL REDHED
578 I(NSSTFL,
579 O TYPE ,IDSST ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE,
580 O IBACK ,NNSP ,
581 O IMD ,JMD ,NPROD ,FLONID, FLATID,
582 O XID ,XJD ,XLATD ,XLOND ,
583 O VCODD ,KMD ,A ,B ,
584 O IMM ,JMM ,NPROM ,FLONIM, FLATIM,
585 O XIM ,XJM ,XLATM ,XLONM ,
586 O VCODM ,KMM ,AAM ,BBM ,
587 O CINF )
588 C =================================================================
589 C >>> SST ANOMALLY <<<
590 C =================================================================
591 DO 1 I=1,NNSP
592 READ(NSSTFL)
593 1 CONTINUE
594 3001 CALL REDDAT
595 I(NSSTFL,
596 O IDSST , KT ,
597 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
598 O SSTA , IRTN ,
599 I ISST , JSST , 1 ,
600 W BASE , AMP ,I2 )
601 IF(ELEM.NE.'SSTA') GOTO 3001
602 WRITE(6,*) '## ', TITLE, '(',UNIT,')'
603 ENDIF
604 C
605 WRITE(6,*) '## ', IDSST, KT
606 IF( IDCHCK.EQ.1 ) THEN
607 CALL CVDATE( IDGES, IDSST, 24 )
608 IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR.
609 1 IDATE(3).NE.IDGES(3) ) THEN
610 WRITE(6,*) 'SSTA : DATE CHECK ERROR'
611 STOP 999
612 ENDIF
613 ENDIF
614 C
615 CALL LT2GAU(SSTA,ISST,JSST,IMAX,JMAX,COLRAD,GSST,DY,LY)
616 CALL MOVERD(GSST, WRK, IMAX*JMAX)
617 CALL WRTDAT
618 1(NINFL , IDATE , -1 , 'SURF', 'SSTA',
619 2 'SST ANOMALLY ', 'K ',
620 3 0 , 0 , WRK , IMAX , JMAX , I2 )
621 WRITE(6,*) '## SST ANOMALLY WAS WRITTEN'
622 C
623 ENDIF
624 C
625 C *****************************************************************
626 C >>> SNOW ANALYSIS <<<
627 C *****************************************************************
628 IF( NSNWFL.NE.-1 ) THEN
629 C =================================================================
630 C >>> HEADER <<<
631 C =================================================================
632 CALL REDHED
633 I(NSNWFL,
634 O TYPE ,IDSST ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE,
635 O IBACK ,NNSP ,
636 O IMD ,JMD ,NPROD ,FLONID, FLATID,
637 O XID ,XJD ,XLATD ,XLOND ,
638 O VCODD ,KMD ,A ,B ,
639 O IMM ,JMM ,NPROM ,FLONIM, FLATIM,
640 O XIM ,XJM ,XLATM ,XLONM ,
641 O VCODM ,KMM ,AAM ,BBM ,
642 O CINF )
643 DO 2 I=1,NNSP
644 READ(NSNWFL)
645 2 CONTINUE
646 C =================================================================
647 C >>> SNOW ANALYSIS <<<
648 C =================================================================
649 CALL REDDAT
650 I(NSNWFL,
651 O IDSST , KT ,
652 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
653 O SEWA , IRTN ,
654 I ISNW , JSNW , 1 ,
655 W BASE , AMP ,I2 )
656 WRITE(6,*) '## ', TITLE, '(',UNIT,')'
657 WRITE(6,*) '## ', IDSST, KT
658 IF( IDCHCK.EQ.1 ) THEN
659 CALL CVDATE( IDGES, IDSST, 24 )
660 IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR.
661 1 IDATE(3).NE.IDGES(3) ) THEN
662 WRITE(6,*) 'SNOW : DATE CHECK ERROR'
663 STOP 999
664 ENDIF
665 ENDIF
666 C -----
667 CALL SETWHT (IMAX,JMAX,DP,IP,GAUL,GAUW,COCOT)
668 DO 100 J=1,180
669 DO 100 I=1,360
670 WORK(I+1,J+1)=SEWA(I,J)
671 100 CONTINUE
672 DO 200 J=1,180
673 WORK( 1,J+1)=WORK(361,J+1)
674 WORK(362,J+1)=WORK( 2,J+1)
675 200 CONTINUE
676 DO 300 I=1,362
677 WORK(I, 1)=WORK(I, 2)
678 WORK(I,182)=WORK(I,181)
679 300 CONTINUE
680 CALL INTERP(WORK,GSNW,IMAX,JMAX,DP,IP)
681 C
682 DO 400 J=1,JMAX
683 DO 410 I=1,IMAX
684 GSNW(I,J)=GSNW(I,J)/100.0
685 410 CONTINUE
686 400 CONTINUE
687 C -----
688 CALL MOVERD(GSNW, WRK, IMAX*JMAX)
689 CALL WRTDAT
690 1(NINFL , IDATE , -1 , 'SURF', 'SEW ',
691 2 'SNOW EQUIVALENT WATER ', 'M ',
692 3 0 , 0 , WRK , IMAX , JMAX , I2 )
693 WRITE(6,*) '## SNOW ANALYSIS WAS WRITTEN'
694 ENDIF
695 C =================================================================
696 C >>> EOF <<<
697 C =================================================================
698 WRITE(6,*) '## PREGSM IS NORMAL ENDED'
699 !modified shc nk start
700 !modified shc nk end
701 C
702 END SUBROUTINE PREGSM1 !shc end