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