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