REDIEG.inc
References to this file elsewhere.
1 C======================================================================
2 C >>> REDIEG <<< READ INITIAL DATA(GRID) AND CONVERT TO WAVE
3 C======================================================================
4 SUBROUTINE REDIEG
5 I(NIEGFL,ITPGFL,IMAX,JMAX,KMAX,IMX ,MEND1,NEND1,JEND1,
6 I MNWAV ,JMAXHF,KMX2 ,KQDMAX,KTSTAR,LAG ,ITOPOG,MWVORG,
7 I PNM ,IFAX ,TRIG ,GW ,SINCLT,COSCLT,ALP ,DALP ,
8 O QDATA ,QPHIS ,IDATE ,ISTP ,KTM ,KT0 ,FSECM ,FSEC0 ,
9 #if (defined CW)
10 O PA ,PB ,CWCM ,CWCP ,CVRM ,CVRP ,XMB ,CINF ,
11 #else
12 O PA ,PB ,CWCM , CVRP , CINF ,
13 #endif
14 W RAA ,RBB ,IDA ,DATA ,EDAT1 ,EDAT2 ,EDAT3 ,WDATA )
15 CMM W PNMGC ,DPNMGC)
16 C
17 C IMPLICIT DOUBLE PRECISION (A-H,O-Z,\)
18 C
19 C...FILE
20 CHARACTER*8 FILE, MODEL, RESL
21 CHARACTER*4 TYPE, EXPR, KTUNIT
22 INTEGER IMD, JMD, IMM, JMM
23 CHARACTER*4 NPROD, NPROM
24 CHARACTER*4 VCODD, VCODM
25 INTEGER KMD, KMM
26 REAL RAA(KMAX+1), RBB(KMAX+1)
27 CHARACTER*80 CINF2(10)
28 C...OUTPUT
29 DIMENSION QDATA(KQDMAX,MNWAV), QPHIS(2,MNWAV)
30 INTEGER IDATE(5)
31 DIMENSION PA(KMAX+1), PB(KMAX+1)
32 DIMENSION CWCM(IMAX*JMAX*KMAX), CVRM(IMAX*JMAX*KMAX)
33 #if (defined CW)
34 DIMENSION CWCP(IMAX*JMAX*KMAX), CVRP(IMAX*JMAX*KMAX)
35 DIMENSION XMB(IMAX*JMAX*KMAX)
36 #endif
37 CHARACTER*80 CINF
38 C...WORK
39 INTEGER*2 IDA(IMAX*JMAX)
40 REAL DATA(IMAX*JMAX)
41 CHARACTER* 4 LEVEL, ELEM
42 CHARACTER*32 TITLE
43 CHARACTER*16 UNIT
44 DIMENSION EDAT1(IMX*JMAX*KMAX)
45 DIMENSION EDAT2(IMX*JMAX*KMAX)
46 DIMENSION EDAT3(IMX*JMAX*KMAX)
47 DIMENSION WDATA(KMX2,MNWAV,2)
48 CMM DIMENSION WDATA(KMX2*MNWAV*2)
49 CMM DIMENSION PNMGC(MNWAV*JMAXHF), DPNMGC(MNWAV*JMAXHF)
50 C...INPUT
51 DIMENSION PNM(MNWAV,JMAXHF), IFAX(10), TRIG(IMAX), GW(JMAX)
52 DIMENSION SINCLT(JMAX), COSCLT(JMAX)
53 INTEGER LAG(MEND1,NEND1)
54 DIMENSION ALP(MNWAV), DALP(MNWAV)
55 CHARACTER*4 MWVORG,IWORG,INOUT
56 DATA IWORG,INOUT/'CLMN','IN '/
57 DATA ER/6371.D3/
58 C
59 COMMON/COMPTR/KQA ,KQB ,KQF ,KQP ,KQE ,KQZ ,
60 1 KQTMP,KQWV,KQROT,KQDIV,KQU ,KQV ,KQPS,KDROT,KDWV,
61 2 MQTMP,MQWV,MQROT,MQDIV ,MQPS
62 C
63 C =================================================================
64 C >>> INPUT TOPOGRAPHY FILE <<<
65 C =================================================================
66 READ(ITPGFL) MDIM
67 IF(MDIM.NE.MEND1) THEN
68 WRITE(6,*)'TOPOGRAPHY FILE IRRELEVANT MEND1,MDIM=',MEND1,MDIM
69 STOP 9999
70 END IF
71 CMM READ(ITPGFL) ((WDATA(K,L),K=3, 4),L=1,MNWAV)
72 C
73 C *****************************************************************
74 C >>> INPUT INITIAL DATA <<<
75 C *****************************************************************
76 CALL REDHED
77 I(NIEGFL,
78 O TYPE ,IDATE ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE,
79 O IBACK ,NNSP ,
80 O IMD ,JMD ,NPROD ,FLONID, FLATID,
81 O XID ,XJD ,XLATD ,XLOND ,
82 O VCODD ,KMD ,RAA ,RBB ,
83 O IMM ,JMM ,NPROM ,FLONIM, FLATIM,
84 O XIM ,XJM ,XLATM ,XLONM ,
85 O VCODM ,KMM ,EDAT1 ,EDAT2 ,
86 O CINF2 )
87 WRITE(6,*) IDATE, FILE,MODEL,RESL,EXPR
88 WRITE(CINF(1:80),'(A80)') CINF2(1) ! FOR LONG FORECAST DIVISION
89 C IF( FILE.NE.'INITETA ' ) THEN
90 C WRITE(6,*) 'FILE ERROR! THIS IS NOT INITIAL DATA'
91 C STOP 999
92 C ENDIF
93 IF( IMAX.NE.IMD.OR.JMAX.NE.JMD.OR.KMAX.NE.KMD ) THEN
94 WRITE(6,*) 'DIMENSION ERROR'
95 STOP 999
96 ENDIF
97 C
98 DO 10 K=1,KMD
99 PA(K)=RAA(K)
100 PB(K)=RBB(K)
101 10 CONTINUE
102 C
103 KT0=-1
104 ISTP=0
105 FSEC0=0.0
106 C
107 C =================================================================
108 C >>> PS <<<
109 C =================================================================
110 1100 CALL REDDAT
111 I(NIEGFL,
112 O IDATE , KT ,
113 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
114 O DATA , IRTN ,
115 I IMD , JMD , KMD ,
116 W BASE , AMP ,IDA )
117 IF( IRTN.EQ.-1 ) THEN
118 WRITE(6,*) '*** I CANNOT FIND INITIAL DATA KT=', KTSTAR
119 STOP 999
120 ENDIF
121
122 C write(*,*)'REDIEG : KT=',KT,KTSTAR,LEVEL,' ',ELEM
123
124 IF( KT.NE.KTSTAR ) GOTO 1100
125 IF( LEVEL.NE.'SURF'.OR.ELEM.NE.'P ' ) GOTO 1100
126 C WRITE(6,*) 'REDIEG : LEVEL=',LEVEL, 'ELEM=',ELEM, DATA(10*10)
127 CALL RESET(EDAT1,IMAX*JMAX*KMAX)
128 CALL MOVERD(DATA,EDAT1,IMD*JMD)
129 CALL MNMX(EDAT1,IMAX*JMAX,'QPS ')
130 CALL RESET(WDATA,KMX2*MNWAV)
131 CALL G2W
132 I(MEND1,NEND1,JEND1,MNWAV,IMAX,JMAX,IMX ,JMAXHF, 1,
133 I PNM ,EDAT1,IFAX ,TRIG ,GW ,
134 O WDATA(1,1,2),
135 CMM O WDATA(KMX2*MNWAV+1),
136 W EDAT2)
137 CALL REOWAV (WDATA(1,1,2),WDATA,MEND1,NEND1,JEND1,MNWAV,
138 CMM CALL REOWAV (WDATA(KMX2*MNWAV+1),WDATA,MEND1,NEND1,JEND1,MNWAV,
139 1 2, KMX2,0, 0, 2,LAG,IWORG,INOUT)
140 CALL WAVMAG (WDATA,MNWAV,KMAX,'QPS ')
141 C
142 READ(ITPGFL) ((WDATA(K,L,1),K=3,4),L=1,MNWAV)
143 CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
144 1 KMX2,KQDMAX,0,KQPS, 2,LAG,IWORG,INOUT)
145 C
146 REWIND ITPGFL
147 IF(ITOPOG.EQ.1) THEN
148 CALL REOWAV (WDATA,QPHIS,MEND1,NEND1,JEND1,MNWAV,
149 1 KMX2, 2,2, 0, 2,LAG,MWVORG,INOUT)
150 ELSE
151 DO 100 K=1,2
152 DO 100 L=1,MNWAV
153 QPHIS(K,L)=0.0
154 100 CONTINUE
155 END IF
156 C
157 C =================================================================
158 C >>> U, V -> ROT, DIV <<<
159 C =================================================================
160 DO 1200 K=1,KMAX
161 1210 CALL REDDAT
162 I(NIEGFL,
163 O IDATE , KT ,
164 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
165 O DATA , IRTN ,
166 I IMD , JMD , KMD ,
167 W BASE , AMP ,IDA )
168 IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'U ' ) GOTO 1210
169 CALL MOVERD(DATA,EDAT1(IMD*JMD*(K-1)+1),IMD*JMD)
170 1200 CONTINUE
171 DO 1300 K=1,KMAX
172 1310 CALL REDDAT
173 I(NIEGFL,
174 O IDATE , KT ,
175 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
176 O DATA , IRTN ,
177 I IMD , JMD , KMD ,
178 W BASE , AMP ,IDA )
179 IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'V ' ) GOTO 1310
180 CALL MOVERD(DATA,EDAT2(IMD*JMD*(K-1)+1),IMD*JMD)
181 1300 CONTINUE
182 C
183 DO 1320 J=1,JMAXHF
184 CALL LGNDR1(COSCLT(J),MEND1,ALP,DALP)
185 DO 1330 MN=1,MNWAV
186 CWCM (MN+(J-1)*MNWAV)= ALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
187 CVRM (MN+(J-1)*MNWAV)=DALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
188 CMM PNMGC(MN+(J-1)*MNWAV)= ALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
189 CMM DPNMGC(MN+(J-1)*MNWAV)=DALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
190 1330 CONTINUE
191 1320 CONTINUE
192 CALL G2WDZ
193 I(MEND1, NEND1 , JEND1, MNWAV, IMAX, JMAX , IMX , JMAXHF, KMAX,
194 I CWCM , CVRM , EDAT1, EDAT2, ER , SINCLT, IFAX, TRIG ,
195 CMM I PNMGC, DPNMGC, EDAT1, EDAT2, ER , SINCLT, IFAX, TRIG ,
196 O WDATA, WDATA(1,1,2),
197 CMM O WDATA, WDATA(KMX2*MNWAV+1),
198 W EDAT3)
199 CALL WAVMAG (WDATA,MNWAV,KMAX,'QROT')
200 CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
201 1 KMX2,KQDMAX,0,KQROT,KMX2,LAG,IWORG,INOUT)
202 CALL WAVMAG (WDATA(1,1,2),MNWAV,KMAX,'QDIV')
203 CMM CALL WAVMAG (WDATA(KMX2*MNWAV+1),MNWAV,KMAX,'QDIV')
204 CALL REOWAV (WDATA(1,1,2),QDATA,MEND1,NEND1,JEND1,MNWAV,
205 CMM CALL REOWAV (WDATA(KMX2*MNWAV+1),QDATA,MEND1,NEND1,JEND1,MNWAV,
206 1 KMX2,KQDMAX,0,KQDIV,KMX2,LAG,IWORG,INOUT)
207 C
208 C =================================================================
209 C >>> T <<<
210 C =================================================================
211 DO 1400 K=1,KMAX
212 1410 CALL REDDAT
213 I(NIEGFL,
214 O IDATE , KT ,
215 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
216 O DATA , IRTN ,
217 I IMD , JMD , KMD ,
218 W BASE , AMP ,IDA )
219 IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'T ' ) GOTO 1410
220 CALL MOVERD(DATA,EDAT1(IMD*JMD*(K-1)+1),IMD*JMD)
221 1400 CONTINUE
222 CALL G2W
223 I(MEND1,NEND1,JEND1,MNWAV,IMAX,JMAX,IMX ,JMAXHF,KMAX,
224 I PNM ,EDAT1,IFAX ,TRIG ,GW ,
225 O WDATA,
226 W EDAT2)
227 CALL WAVMAG (WDATA,MNWAV,KMAX,'QTMP')
228 CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
229 1 KMX2,KQDMAX,0,KQTMP,KMX2,LAG,IWORG,INOUT)
230 C
231 C =================================================================
232 C >>> Q <<<
233 C =================================================================
234 DO 1500 K=1,KMAX
235 1510 CALL REDDAT
236 I(NIEGFL,
237 O IDATE , KT ,
238 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
239 O DATA , IRTN ,
240 I IMD , JMD , KMD ,
241 W BASE , AMP ,IDA )
242 IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'Q ' ) GOTO 1510
243 CALL MOVERD(DATA,EDAT1(IMD*JMD*(K-1)+1),IMD*JMD)
244 C
245 DO 1520 I=1,IMD*JMD
246 IF(EDAT1(IMD*JMD*(K-1)+I).LT.0.0)
247 1 EDAT1(IMD*JMD*(K-1)+I)=0.0
248 1520 CONTINUE
249 1500 CONTINUE
250 CALL G2W
251 I(MEND1,NEND1,JEND1,MNWAV,IMAX,JMAX,IMX ,JMAXHF,KMAX,
252 I PNM ,EDAT1,IFAX ,TRIG ,GW ,
253 O WDATA,
254 W EDAT2)
255 CALL WAVMAG (WDATA,MNWAV,KMAX,'QWV ')
256 CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
257 1 KMX2,KQDMAX,0,KQWV ,KMX2,LAG,IWORG,INOUT)
258 #if (defined CW)
259 C =================================================================
260 C >>> CWC, CVR, XMB <<<
261 C =================================================================
262 DO 1600 K=1,KMAX
263 1610 CALL REDDAT
264 I(NIEGFL,
265 O IDATE , KT ,
266 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
267 O DATA , IRTN ,
268 I IMD , JMD , KMD ,
269 W BASE , AMP ,IDA )
270 IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'CWC ' ) GOTO 1610
271 CALL MOVERD(DATA,CWCP(IMD*JMD*(K-1)+1),IMD*JMD)
272 CALL MOVERD(DATA,CWCM(IMD*JMD*(K-1)+1),IMD*JMD)
273 C
274 DO 1620 I=1,IMD*JMD
275 IF(CWCP(IMD*JMD*(K-1)+I).LT.0.0)
276 1 CWCP(IMD*JMD*(K-1)+I)=0.0
277 IF(CWCM(IMD*JMD*(K-1)+I).LT.0.0)
278 1 CWCM(IMD*JMD*(K-1)+I)=0.0
279 1620 CONTINUE
280 1600 CONTINUE
281 DO 1700 K=1,KMAX
282 1710 CALL REDDAT
283 I(NIEGFL,
284 O IDATE , KT ,
285 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
286 O DATA , IRTN ,
287 I IMD , JMD , KMD ,
288 W BASE , AMP ,IDA )
289 IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'CVR ' ) GOTO 1710
290 CALL MOVERD(DATA,CVRP(IMD*JMD*(K-1)+1),IMD*JMD)
291 CALL MOVERD(DATA,CVRM(IMD*JMD*(K-1)+1),IMD*JMD)
292 C
293 DO 1720 I=1,IMD*JMD
294 IF(CVRP(IMD*JMD*(K-1)+I).LT.0.0)
295 1 CVRP(IMD*JMD*(K-1)+I)=0.0
296 IF(CVRM(IMD*JMD*(K-1)+I).LT.0.0)
297 1 CVRM(IMD*JMD*(K-1)+I)=0.0
298 1720 CONTINUE
299 1700 CONTINUE
300 DO 1800 K=1,KMAX
301 1810 CALL REDDAT
302 I(NIEGFL,
303 O IDATE , KT ,
304 O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
305 O DATA , IRTN ,
306 I IMD , JMD , KMD ,
307 W BASE , AMP ,IDA )
308 IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'UMB ' ) GOTO 1810
309 CALL MOVERD(DATA,XMB(IMD*JMD*(K-1)+1),IMD*JMD)
310 C
311 DO 1820 I=1,IMD*JMD
312 IF(XMB(IMD*JMD*(K-1)+I).LT.0.0)
313 1 XMB(IMD*JMD*(K-1)+I)=0.0
314 1820 CONTINUE
315 1800 CONTINUE
316 #endif
317 C
318 C *****************************************************************
319 C >>> ( T - DELT T ) <<<
320 C *****************************************************************
321 C
322 CC IF(KTSTAR.LE.0) THEN
323 DO 2000 K=1,KMX2
324 *VOPTION INDEP
325 *vdir nodep
326 DO 2000 L=1,MNWAV
327 QDATA(MQTMP+K,L)=QDATA(KQTMP+K,L)
328 QDATA(MQROT+K,L)=QDATA(KQROT+K,L)
329 QDATA(MQDIV+K,L)=QDATA(KQDIV+K,L)
330 QDATA(MQWV +K,L)=QDATA(KQWV +K,L)
331 2000 CONTINUE
332 DO 2010 K=1, 2
333 *VOPTION INDEP
334 *vdir nodep
335 DO 2010 L=1,MNWAV
336 QDATA(MQPS +K,L)=QDATA(KQPS +K,L)
337 2010 CONTINUE
338 CC ENDIF
339 C
340 RETURN
341 END SUBROUTINE REDIEG
342