| blob | ad4004d759d2056cd5a5df4a034e21bdac49b441 |
1 C***********************************************************************
2 PROGRAM PREGSM
3 USE module_wave2grid_kma
4 ! Duplicated in module
5 ! PARAMETER ( KMAX=30 )
6 ! PARAMETER ( IMAX=640, JMAX=320 )
7 ! PARAMETER ( IMAXE=640, JMAXE=321 )
8 ! PARAMETER ( ISST=360, JSST=181 )
9 ! PARAMETER ( ISNW=360, JSNW=180 )
10 ! PARAMETER ( IDIM=428, JDIM=214 ) ! MAX(MAX,SST,SNW)
11 ! PARAMETER ( MAXJZ=16 )
12 ! PARAMETER (MEND1 =214,NEND1=214,JEND1=214)
13 ! PARAMETER (JMAXHF= JMAX/2)
14 ! PARAMETER (MNWAV =MEND1*(MEND1+1)/2)
15 ! PARAMETER (IVAR=6,IMX=IMAX+2)
16 C
17 INTEGER IDATE(5), IDGES(5), IDSST(5)
18 CHARACTER*8 FILE, MODEL, RESL
19 CHARACTER*80 CINF(10)
20 CHARACTER*4 TYPE, EXPR, KTUNIT, NPROD, NPROM, VCODD, VCODM
21 CHARACTER*4 LEVEL, ELEM
22 CHARACTER*32 TITLE
23 CHARACTER*16 UNIT
24 CHARACTER*8 MDLINF(4)
25 REAL DTHPRO(7)
26 INTEGER ITYP(2)
27 CHARACTER*48 LABEL
28 INTEGER JTINF(2)
29 CHARACTER*10 FROMUNPACK
30 INTEGER IUNPACK
31 C
32 DIMENSION A(KMAX+1), B(KMAX+1), AAM(KMAX+1), BBM(KMAX+1)
33 DIMENSION AGD(KMAX+1), BGD(KMAX+1), AGM(KMAX+1), BGM(KMAX+1)
34 DIMENSION GPHIS(IMAX*JMAX)
35 REAL, DIMENSION(IMAX,JMAX) :: GAU
36 REAL, DIMENSION(JMAX) :: SINCLT,COSCLT,GW,DGW,DCOSCL,COLRAD,DY
38 COMMON PSE (IMAXE,JMAXE),
39 1 GZE (IMAXE,JMAXE,KMAX), GTE (IMAXE,JMAXE,KMAX),
40 2 GUE (IMAXE,JMAXE,KMAX), GVE (IMAXE,JMAXE,KMAX),
41 3 GQE (IMAXE,JMAXE,KMAX)
42 COMMON PS (IMAX,JMAX),
43 1 GZ (IMAX,JMAX,KMAX), GT (IMAX,JMAX,KMAX),
44 2 GU (IMAX,JMAX,KMAX), GV (IMAX,JMAX,KMAX),
45 3 GQ (IMAX,JMAX,KMAX), AGT (IMAX,JMAX,KMAX),
46 4 GCWC(IMAX,JMAX,KMAX), GCVR(IMAX,JMAX,KMAX),
47 5 GUMB(IMAX,JMAX,KMAX),
48 6 GSST(IMAX,JMAX) , GSNW(IMAX,JMAX)
49 DIMENSION VLG(IMAX,JMAX,KMAX)
50 C DIMENSION WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX),
51 REAL * 8 WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX)
52 DIMENSION WRK3(IMAX,JMAX,KMAX), WRK4(IMAX,JMAX,KMAX),
53 2 WRK5(IMAX,JMAX,KMAX), WRK6(IMAX,JMAX,KMAX)
54 CHARACTER*4 ALVL
55 INTEGER*2 I2(IDIM*JDIM)
56 REAL*8 WRK(IDIM,JDIM)
57 DIMENSION SSTA(ISST*JSST), SEWA(ISNW,JSNW)
58 DIMENSION COLRAD(JMAX), DY(JMAX), LY(JMAX)
59 DIMENSION WORK(362,182),DP(4,IMAX,JMAX)
60 INTEGER*2 IP(2,IMAX,JMAX)
61 REAL*8 GAUL(JMAX),GAUW(JMAX),COCOT(JMAX)
62 COMMON/CTETEN/TABLE(25000)
63 COMMON/DTETEN/DTABLE(25000)
64 REAL*8 TABLE,DTABLE,RGSA,G
65 DIMENSION RLAT(MAXJZ), ZDAT(MAXJZ,KMAX)
66 C
67 NAMELIST /NAMFIL/ NALFL,NVPFL,NGSFL,NSSTFL,NSNWFL,NINFL,
68 1 KTLAG,IDCHCK,NDIGFL,NTPFL,NALOT,NRSFL
69 NAMELIST /HEADIN/ TYPE,FILE,KTUNIT,IDTYPE,
70 1 IBACK,NNSP
71 C------------------------------------------------------------------------
72 C NALFL : 3DOI INPUT FILE
73 C NVPFL : VERTIAL LEVEL DEF. FILE
74 C NTPFL : TOPO FILE
75 C NALOT : 3DOI INPUT SAVE FILE
76 C NRSFL : UNPACK INPUT FILE
77 C------------------------------------------------------------------------
78 NAMELIST /NAMVER/ MODEL, RESL, EXPR, CINF
79 C
80 DATA RHMIN/1.0E-3/
81 DATA GRAV,ER,GASR,GAMMA/9.80665,6371.E3,287.04,0.0050/
82 DATA TLAPS,QCONS,QMIN,KST,ITERMX/2.0E-3,2.5E-6,1.0E-10,10,3/
83 C
84 DATA NALFL ,NGSFL ,NSSTFL,NSNWFL,NINFL ,NVPFL ,NALOT,NRSFL
85 1 / 1, 2, -1, -1, 11, 21, 12, -1/
86 DATA KTLAG / 6/
87 DATA IDCHCK/ 1/
88 DATA A/0.00000000000D+00,0.00000000000D+00,0.00000000000D+00,
89 & 0.00000000000D+00,1.546082500000000,5.614406590000000,
90 & 12.42546270000000,21.63197330000000,32.59785460000000,
91 & 44.61235050000000,57.01704410000000,69.26280210000000,
92 & 80.92097470000000,91.66931150000001,101.2670900000000,
93 & 109.5278170000000,116.2947540000000,121.4214780000000,
94 & 124.7591550000000,126.1514430000000,125.4377290000000,
95 & 122.4657440000000,117.1135710000000,109.3194430000000,
96 & 99.11479190000000,86.65005490000000,72.19601440000000,
97 & 56.09729000000000,38.66041560000000,19.99998470000000,
98 & 0.00000000000D+00/
99 DATA B/1.0000000000000,0.9889042970000000,0.9682830569999999,
100 & 0.9399999980000000,0.9042294030000000,0.8613848090000000,
101 & 0.8124753240000000,0.7589231130000000,0.7022829060000000,
102 & 0.6440208549999999,0.5853865740000000,0.5273658630000000,
103 & 0.4706876280000000,0.4158638720000000,0.3632441160000000,
104 & 0.3130739930000000,0.2655510310000000,0.2208738920000000,
105 & 0.1792818900000000,0.1410827640000000,0.1066635850000000,
106 & 7.647979300000D-02,5.101471400000D-02,3.070007300000D-02,
107 & 1.579232499999D-02,6.205350000000D-03,1.324939000000D-03,
108 & 0.000000000000D+00,0.000000000000D+00,0.000000000000D+00,
109 & 0.000000000000D+00/
110 C
111 C =================================================================
112 C >>> READ ANAL TIME <<<
113 C =================================================================
114 READ(94,'(I4,3I2)') (IDATE(I),I=1,4)
115 IDATE(5)=0
116 C =================================================================
117 C >>> NAMELIST (NAMFIL) <<<
118 C =================================================================
119 READ(95,NAMFIL)
120 READ(95,HEADIN)
121 WRITE(6,NAMFIL)
122 WRITE(6,HEADIN)
123 C =================================================================
124 C >>> Select Input Source <<<
125 C =================================================================
126 CALL GETENV('FROMUNPACK',FROMUNPACK)
127 IF (LEN_TRIM(FROMUNPACK).EQ.0) THEN
128 IUNPACK=0
129 ELSE
130 READ(FROMUNPACK,'(I1)') IUNPACK
131 END IF
132 WRITE(6,*)'IUNPACK=',IUNPACK
133 C =================================================================
134 C >>> GENERATE GAUSSIAN LATITUDES <<<
135 C =================================================================
136 CALL GAUSS(GAUL,GAUW,JMAX)
137 DO 800 J=1,JMAX
138 COLRAD(J)=ACOS(GAUL(J))
139 800 CONTINUE
140 DO J=1,JMAXHF
141 *vdir nodep
142 GW ( J)=0.5*DGW (J)
143 GW (JMAX+1-J)=0.5*DGW (J)
144 COSCLT( J)= DCOSCL(J)
145 COSCLT(JMAX+1-J)= -DCOSCL(J)
146 SINCLT( J)=SQRT(1.0-DCOSCL(J)**2)
147 SINCLT(JMAX+1-J)=SQRT(1.0-DCOSCL(J)**2)
148 END DO
149 CALL ZMNLAT( RLAT, MAXJZ, COLRAD, JMAX )
150 C
151 C =================================================================
152 C >>> TETEN <<<
153 C =================================================================
154 ICE = 1
155 CALL TETEN(ICE)
156 C =================================================================
157 C >>> READ TOPO FILE
158 C =================================================================
159 IF (NTPFL.GT.0) THEN
160 READ(NTPFL)NWV,DUM,IGRD,JGRD
161 IF ((IGRD.NE.IMAX).OR.(JGRD.NE.JMAX)) THEN
162 WRITE(*,*)' TOPO DIM DOES NOT MATCH'
163 WRITE(*,*)'IMAX=',IMAX,' IGRD=',IGRD
164 WRITE(*,*)'JMAX=',JMAX,' JGRD=',JGRD
165 STOP 9988
166 END IF
167 READ(NTPFL)
168 READ(NTPFL)
169 READ(NTPFL)GPHIS
170 WRITE(*,*)'GRID DISTANCE=',DUM
171 END IF
172 C---------------------------------------------------------------------
173 C READ INPUT DATA
174 C---------------------------------------------------------------------
175 IF (NRSFL.LE.0) THEN
177 CALL REDDAT_ASCII
178 CLSW CALL REDDAT_BIN
179 I(NALFL ,IMAXE ,JMAXE ,KMAX , PSE,
180 O GTE ,GUE ,GVE ,GQE )
181 C---------------------------------------------------------------------
182 C +++ CONVERT LAT/LON to GAUSS
183 C---------------------------------------------------------------------
184 CALL LT2GAU (PSE,IMAXE,JMAXE,IMAX,JMAX,
185 1 COLRAD,PS,DY,LY)
186 DO K = 1, KMAX
187 CALL LT2GAU (GTE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
188 1 COLRAD,GT(:,:,K),DY,LY)
189 CALL LT2GAU (GUE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
190 1 COLRAD,GU(:,:,K),DY,LY)
191 CALL LT2GAU (GVE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
192 1 COLRAD,GV(:,:,K),DY,LY)
193 CALL LT2GAU (GQE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
194 1 COLRAD,GQ(:,:,K),DY,LY)
195 ENDDO
196 C =================================================================
197 C >>> PS, TEMP, Q -> Z
198 C =================================================================
199 RGAS = 287.04
200 G = 9.80665
201 CALL GPLHGT
202 I (PS,GT,GQ,GPHIS,IMAX,JMAX,KMAX,RGAS,G,A,B,
203 I 1,JMAX,
204 O GZ)
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 ELSE ! START WITH UNPACK FILE
223 LARHM=20
224 READ(NRSFL)IDATE
225 READ(NRSFL)PS
226 READ(NRSFL)GZ
227 READ(NRSFL)GU
228 READ(NRSFL)GV
229 READ(NRSFL)GQ
230 READ(NRSFL)AGT
232 END IF ! READ ANAL FINISH
234 CLSW write(99,*) ' Gauss GT'
235 CLSW do k=1,2
236 CLSW do j=1,jmax
237 CLSW write(99,FMT='(10F12.5,1x)') (GT(I,J,k),I=1,IMAX)
238 CLSW enddo
239 CLSW enddo
240 C---------------------------------------------------------------------
241 C DO J = 1, JMAX
242 C write(99,FMT='(10F12.5,1x)') (GAU(I,J),I=1,IMAX)
243 C ENDDO
245 1000 CONTINUE
247 C =================================================================
248 C >>> NAMELIST (NAMVER) <<<
249 C =================================================================
250 CINF(1)=' ';CINF(2)=' ';CINF(3)=' ';CINF(4)=' ';CINF(5)=' '
251 CINF(6)=' ';CINF(7)=' ';CINF(8)=' ';CINF(9)=' ';CINF(10)=' '
252 READ(95,NAMVER)
253 WRITE(6,NAMVER)
254 C =================================================================
255 IF(NGSFL.GE.0) THEN
256 CALL REDGES
257 I(NGSFL ,IMAX ,JMAX ,KMAX ,KTLAG ,IDATE ,IDCHCK,
258 O IDGES ,AGD ,BGD ,AGM ,BGM ,GCWC ,GCVR ,GUMB ,
259 W I2 ,IDSST )
260 ENDIF
261 C =================================================================
262 C >>> Z -> TV <<<
263 C =================================================================
264 C CALL CTIME( 4, 'ZE2TVE ' )
265 C >>> GT IS TV (OUTPUT)
266 IF (NTPFL.LT.0) THEN
267 CALL GH2TV(GZ, GT, PS, GPHIS, A, B,
268 1 IMAX , JMAX , KMAX ,WRK1 , WRK2 , WRK3 , WRK4)
269 ELSE
270 CALL ZE2TVE( GZ , GT , PS , A , B ,
271 I IMAX , JMAX , KMAX ,
272 W VLG , WRK1 , WRK2 , WRK3 , WRK4 , WRK5 ,
273 W WRK6 )
274 C
275 CLSW write(99,*) ' Z->TV'
276 CLSW do k=1,2
277 CLSW do j=1,jmax
278 CLSW write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX)
279 CLSW enddo
280 CLSW enddo
281 END IF
282 CLSW CALL ZMNT( ZDAT, MAXJZ, KMAX, GT , IMAX, JMAX )
283 CLSW CALL OUTZ( ZDAT, MAXJZ, KMAX, 'TV ',
284 CLSW 1 'TV ', 'K ',
285 CLSW 2 0, RLAT, 'KMAX' )
287 C =================================================================
288 C >>> RH, TV -> Q, T <<<
289 C =================================================================
290 IDX=1
291 CALL CRH2SHA
292 I(IMAX*JMAX, KMAX, PS, A, B, GRAV,GASR,TLAPS,QCONS,QMIN,KST,ITERMX,
293 I IDX, LARHM,
294 O GQ, GT)
295 write(99,*) ' after RH, TV -> Q, T'
296 do k=1,2
297 do j=1,jmax
298 write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX)
299 enddo
300 enddo
302 C *****************************************************************
303 C >>> OUTPUT INITIAL VALUE <<<
304 C *****************************************************************
305 C =================================================================
306 C >>> HEADER <<<
307 C =================================================================
308 CALL WRTHED
309 I(NINFL ,
310 I 'GVS1',IDATE ,'INITETA ',MODEL, RESL,
311 I EXPR ,'HOUR',1 ,0 ,0 ,
312 I IMAX ,JMAX ,'GAUS',360.0/IMAX, REAL(JMAX),
313 I 1.0 ,(JMAX+1)/2.0, 0.0 ,0.0 ,
314 I 'ETA ',KMAX ,A ,B ,
315 I IMAX ,JMAX ,'GAUS',360.0/IMAX, REAL(JMAX),
316 I 1.0 ,(JMAX+1)/2.0, 0.0 ,0.0 ,
317 I 'ETA ',KMAX ,A ,B ,
318 I CINF )
319 C
320 C =================================================================
321 C >>> PS <<<
322 C =================================================================
323 CALL MOVERD(PS, WRK, IMAX*JMAX)
324 CALL WRTDAT
325 1(NINFL , IDATE , -1 , 'SURF', 'P ',
326 2 'P ', 'HPA ',
327 3 0 , 0 , WRK , IMAX , JMAX , I2 )
328 C
329 C =================================================================
330 C >>> U, V <<<
331 C =================================================================
332 DO 9030 K=1,KMAX
333 CALL MOVERD(GU(1,1,K), WRK, IMAX*JMAX)
334 WRITE(ALVL(1:4), '(I4)') K
335 CALL WRTDAT
336 1 (NINFL , IDATE , -1 , ALVL , 'U ',
337 2 'U ', 'M/S ',
338 3 0 , 0 , WRK , IMAX , JMAX , I2 )
339 9030 CONTINUE
340 DO 9040 K=1,KMAX
341 CALL MOVERD(GV(1,1,K), WRK, IMAX*JMAX)
342 WRITE(ALVL(1:4), '(I4)') K
343 CALL WRTDAT
344 1 (NINFL , IDATE , -1 , ALVL , 'V ',
345 2 'V ', 'M/S ',
346 3 0 , 0 , WRK , IMAX , JMAX , I2 )
347 9040 CONTINUE
348 C =================================================================
349 C >>> T, Q <<<
350 C =================================================================
351 DO 9010 K=1,KMAX
352 CALL MOVERD(GT(1,1,K), WRK, IMAX*JMAX)
353 WRITE(ALVL(1:4), '(I4)') K
354 CALL WRTDAT
355 1 (NINFL , IDATE , -1 , ALVL , 'T ',
356 2 'T ', 'K ',
357 3 0 , 0 , WRK , IMAX , JMAX , I2 )
358 9010 CONTINUE
359 DO 9020 K=1,KMAX
360 CALL MOVERD(GQ(1,1,K), WRK, IMAX*JMAX)
361 WRITE(ALVL(1:4), '(I4)') K
362 CALL WRTDAT
363 1 (NINFL , IDATE , -1 , ALVL , 'Q ',
364 2 'Q ', 'KG/KG ',
365 3 0 , 0 , WRK , IMAX , JMAX , I2 )
366 9020 CONTINUE
367 C =================================================================
368 C >>> SAVE INPUT FIELD FOR DIAG.
369 C =================================================================
370 IF (NDIGFL.GT.0) THEN
371 WRITE(NDIGFL)GT
372 WRITE(NDIGFL)GQ
373 END IF
374 C
375 C =================================================================
376 C >>> CWC, CVR <<<
377 C =================================================================
378 IF(NGSFL.GT.0) THEN
379 DO 9050 K=1,KMAX
380 CALL MOVERD(GCWC(1,1,K), WRK, IMAX*JMAX)
381 WRITE(ALVL(1:4), '(I4)') K
382 CALL WRTDAT
383 1 (NINFL , IDATE , -1 , ALVL , 'CWC ',
384 2 'CLOUD WATER CONTENT ', 'KG/KG ',
385 3 0 , 0 , WRK , IMAX , JMAX , I2 )
386 9050 CONTINUE
387 DO 9060 K=1,KMAX
388 CALL MOVERD(GCVR(1,1,K), WRK, IMAX*JMAX)
389 WRITE(ALVL(1:4), '(I4)') K
390 CALL WRTDAT
391 1 (NINFL , IDATE , -1 , ALVL , 'CVR ',
392 2 'CLOUD COVER ', '- ',
393 3 0 , 0 , WRK , IMAX , JMAX , I2 )
394 9060 CONTINUE
395 C
396 C =================================================================
397 C >>> UMB <<<
398 C =================================================================
399 DO 9070 K=1,KMAX
400 CALL MOVERD(GUMB(1,1,K), WRK, IMAX*JMAX)
401 WRITE(ALVL(1:4), '(I4)') K
402 CALL WRTDAT
403 1 (NINFL , IDATE , -1 , ALVL , 'UMB ',
404 2 'UPWARD MASS FLUX AT CLOUD BASE ', 'KG/S/M**2 ',
405 3 0 , 0 , WRK , IMAX , JMAX , I2 )
406 9070 CONTINUE
407 END IF !NGSFL>0
408 C
409 C *****************************************************************
410 C >>> SST ANOMALY <<<
411 C *****************************************************************
412 IF( NSSTFL.NE.-1 ) THEN
413 CALL GETTYP(NSSTFL,IOTYP)
414 C
415 IF(IOTYP.EQ.1) THEN
416 C CALL GVDFIR(NSSTFL,
417 C 1 IDSST,IBACK,IM,JM,MDLINF,DTHPRO,CINF,ITYP,IRTN)
418 C WRITE(6,*) 'GVDFIR:IRTN=',IRTN
419 C CALL GVDFNR(NSSTFL,IDSST,0,'SURF','SSTA',
420 C 1 LABEL,JTINF,SSTA,IRTN)
421 C WRITE(6,*) 'GVDFNR:IRTN=',IRTN
422 WRITE(*,*)' UNKNOWN IOTYP:1'
423 STOP 9999
424 ELSE IF(IOTYP.EQ.3) THEN
425 C =================================================================
426 C >>> HEADER <<<
427 C =================================================================
428 CALL REDHED
429 I(NSSTFL,
430 O TYPE ,IDSST ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE,
431 O IBACK ,NNSP ,
432 O IMD ,JMD ,NPROD ,FLONID, FLATID,
433 O XID ,XJD ,XLATD ,XLOND ,
434 O VCODD ,KMD ,A ,B ,
435 O IMM ,JMM ,NPROM ,FLONIM, FLATIM,
436 O XIM ,XJM ,XLATM ,XLONM ,
437 O VCODM ,KMM ,AAM ,BBM ,
438 O CINF )
439 C =================================================================
440 C >>> SST ANOMALLY <<<
441 C =================================================================
442 DO 1 I=1,NNSP
443 READ(NSSTFL)
444 1 CONTINUE
445 3001 CALL REDDAT
446 I(NSSTFL,
447 O IDSST , KT ,
448 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
449 O SSTA , IRTN ,
450 I ISST , JSST , 1 ,
451 W BASE , AMP ,I2 )
452 IF(ELEM.NE.'SSTA') GOTO 3001
453 WRITE(6,*) '## ', TITLE, '(',UNIT,')'
454 ENDIF
455 C
456 WRITE(6,*) '## ', IDSST, KT
457 IF( IDCHCK.EQ.1 ) THEN
458 CALL CVDATE( IDGES, IDSST, 24 )
459 IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR.
460 1 IDATE(3).NE.IDGES(3) ) THEN
461 WRITE(6,*) 'SSTA : DATE CHECK ERROR'
462 STOP 999
463 ENDIF
464 ENDIF
465 C
466 CALL LT2GAU(SSTA,ISST,JSST,IMAX,JMAX,COLRAD,GSST,DY,LY)
467 CALL MOVERD(GSST, WRK, IMAX*JMAX)
468 CALL WRTDAT
469 1(NINFL , IDATE , -1 , 'SURF', 'SSTA',
470 2 'SST ANOMALLY ', 'K ',
471 3 0 , 0 , WRK , IMAX , JMAX , I2 )
472 WRITE(6,*) '## SST ANOMALLY WAS WRITTEN'
473 C
474 ENDIF
475 C
476 C *****************************************************************
477 C >>> SNOW ANALYSIS <<<
478 C *****************************************************************
479 IF( NSNWFL.NE.-1 ) THEN
480 C =================================================================
481 C >>> HEADER <<<
482 C =================================================================
483 CALL REDHED
484 I(NSNWFL,
485 O TYPE ,IDSST ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE,
486 O IBACK ,NNSP ,
487 O IMD ,JMD ,NPROD ,FLONID, FLATID,
488 O XID ,XJD ,XLATD ,XLOND ,
489 O VCODD ,KMD ,A ,B ,
490 O IMM ,JMM ,NPROM ,FLONIM, FLATIM,
491 O XIM ,XJM ,XLATM ,XLONM ,
492 O VCODM ,KMM ,AAM ,BBM ,
493 O CINF )
494 DO 2 I=1,NNSP
495 READ(NSNWFL)
496 2 CONTINUE
497 C =================================================================
498 C >>> SNOW ANALYSIS <<<
499 C =================================================================
500 CALL REDDAT
501 I(NSNWFL,
502 O IDSST , KT ,
503 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
504 O SEWA , IRTN ,
505 I ISNW , JSNW , 1 ,
506 W BASE , AMP ,I2 )
507 WRITE(6,*) '## ', TITLE, '(',UNIT,')'
508 WRITE(6,*) '## ', IDSST, KT
509 IF( IDCHCK.EQ.1 ) THEN
510 CALL CVDATE( IDGES, IDSST, 24 )
511 IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR.
512 1 IDATE(3).NE.IDGES(3) ) THEN
513 WRITE(6,*) 'SNOW : DATE CHECK ERROR'
514 STOP 999
515 ENDIF
516 ENDIF
517 C -----
518 CALL SETWHT (IMAX,JMAX,DP,IP,GAUL,GAUW,COCOT)
519 DO 100 J=1,180
520 DO 100 I=1,360
521 WORK(I+1,J+1)=SEWA(I,J)
522 100 CONTINUE
523 DO 200 J=1,180
524 WORK( 1,J+1)=WORK(361,J+1)
525 WORK(362,J+1)=WORK( 2,J+1)
526 200 CONTINUE
527 DO 300 I=1,362
528 WORK(I, 1)=WORK(I, 2)
529 WORK(I,182)=WORK(I,181)
530 300 CONTINUE
531 CALL INTERP(WORK,GSNW,IMAX,JMAX,DP,IP)
532 C
533 DO 400 J=1,JMAX
534 DO 410 I=1,IMAX
535 GSNW(I,J)=GSNW(I,J)/100.0
536 410 CONTINUE
537 400 CONTINUE
538 C -----
539 CALL MOVERD(GSNW, WRK, IMAX*JMAX)
540 CALL WRTDAT
541 1(NINFL , IDATE , -1 , 'SURF', 'SEW ',
542 2 'SNOW EQUIVALENT WATER ', 'M ',
543 3 0 , 0 , WRK , IMAX , JMAX , I2 )
544 WRITE(6,*) '## SNOW ANALYSIS WAS WRITTEN'
545 ENDIF
546 C =================================================================
547 C >>> EOF <<<
548 C =================================================================
549 WRITE(6,*) '## PREGSM IS NORMAL ENDED'
550 C
551 STOP
552 END