REDGES.inc
References to this file elsewhere.
1 SUBROUTINE REDGES
2 I(NGSFL ,IMAX ,JMAX ,KMAX ,KTLAG ,IDATE ,IDCHCK,
3 O IDGES ,AGD ,BGD ,AGM ,BGM ,GCWC ,GCVR ,GUMB ,
4 W IDA ,IDSST )
5 C
6 INTEGER IDGES(5), IDATE(5), IDSST(5)
7 DIMENSION GCWC(IMAX*JMAX,KMAX), GCVR(IMAX*JMAX,KMAX),
8 1 GUMB(IMAX*JMAX,KMAX)
9 DIMENSION AGD(KMAX+1), BGD(KMAX+1), AGM(KMAX+1), BGM(KMAX+1)
10 c INTEGER*2 IDA(IMAX*JMAX) !shc-rizvi
11 INTEGER IDA(IMAX*JMAX/2) !shc-rizvi
12 C
13 CHARACTER*4 TYPE, EXPR, KTUNIT, NPROD, NPROM, VCODD, VCODM
14 CHARACTER*8 FILE, MODEL, RESL
15 CHARACTER*80 CINF(10)
16 CHARACTER*4 LEVEL, ELEM
17 CHARACTER*32 TITLE
18 CHARACTER*16 UNIT
19 C
20 C =================================================================
21 C >>> DATA CHECK <<<
22 C =================================================================
23 READ(NGSFL,ERR=1,END=1)
24 GOTO 2
25 1 WRITE(6,*) '## I CANNOT READ FCST FILE'
26 CALL RESET( GCWC, IMAX*JMAX*KMAX )
27 CALL RESET( GCVR, IMAX*JMAX*KMAX )
28 CALL RESET( GUMB, IMAX*JMAX*KMAX )
29 RETURN
30 2 REWIND NGSFL
31 C
32 C =================================================================
33 C >>> HEADER <<<
34 C =================================================================
35 CALL REDHED
36 I(NGSFL ,
37 O TYPE ,IDGES ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE,
38 O IBACK ,NNSP ,
39 O IMD ,JMD ,NPROD ,FLATID,FLONID,
40 O XID ,XJD ,XLATD ,XLOND ,
41 O VCODD ,KMD ,AGD ,BGD ,
42 O IMM ,JMM ,NPROM ,FLATIM,FLONIM,
43 O XIM ,XJM ,XLATM ,XLONM ,
44 O VCODM ,KMM ,AGM ,BGM ,
45 O CINF )
46 WRITE(6,*)'GUESS FILE ',IDGES, FILE, MODEL, RESL, EXPR
47 C
48 C =================================================================
49 C >>> DATE CHECK <<<
50 C =================================================================
51 IF( IDCHCK.EQ.1 ) THEN
52 CALL CVDATE( IDSST, IDGES, KTLAG )
53 IF( IDATE(1).NE.IDSST(1).OR.IDATE(2).NE.IDSST(2).OR.
54 1 IDATE(3).NE.IDSST(3) ) THEN
55 WRITE(6,*) 'GFEG : DATE CHECK ERROR'
56 STOP 999
57 ENDIF
58 ENDIF
59 C
60 C =================================================================
61 C >>> SPECIAL <<<
62 C =================================================================
63 DO 10 I=1,NNSP
64 READ(NGSFL)
65 10 CONTINUE
66 C
67 C =================================================================
68 C >>> CWC, CVR <<<
69 C =================================================================
70 DO 110 K=1,KMAX
71 100 CALL REDDAT
72 I(NGSFL ,
73 O IDGES , KT , LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
74 O GCWC(1,K), IRTN ,
75 I IMD , JMD , 1 ,
76 W BASE , AMP , IDA )
77 IF(KT.NE.KTLAG.OR.LEVEL.EQ.'SURF'.OR.ELEM.NE.'CWC ') GOTO 100
78 110 CONTINUE
79 C
80 DO 210 K=1,KMAX
81 200 CALL REDDAT
82 I(NGSFL ,
83 O IDGES , KT , LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
84 O GCVR(1,K), IRTN ,
85 I IMD , JMD , 1 ,
86 W BASE , AMP , IDA )
87 IF(KT.NE.KTLAG.OR.LEVEL.EQ.'SURF'.OR.ELEM.NE.'CVR ') GOTO 200
88 210 CONTINUE
89 C
90 C =================================================================
91 C >>> UMB <<<
92 C =================================================================
93 DO 310 K=1,KMAX
94 300 CALL REDDAT
95 I(NGSFL ,
96 O IDGES , KT , LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
97 O GUMB(1,K), IRTN ,
98 I IMD , JMD , 1 ,
99 W BASE , AMP , IDA )
100 IF(KT.NE.KTLAG.OR.LEVEL.EQ.'SURF'.OR.ELEM.NE.'UMB ') GOTO 300
101 310 CONTINUE
102 C
103 WRITE(6,*) '## READ FCST-ETA NORMAL END'
104 RETURN
105 END SUBROUTINE REDGES