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