C======================================================================
C >>> REDIEG <<< READ INITIAL DATA(GRID) AND CONVERT TO WAVE
C======================================================================
SUBROUTINE REDIEG
I(NIEGFL,ITPGFL,IMAX,JMAX,KMAX,IMX ,MEND1,NEND1,JEND1,
I MNWAV ,JMAXHF,KMX2 ,KQDMAX,KTSTAR,LAG ,ITOPOG,MWVORG,
I PNM ,IFAX ,TRIG ,GW ,SINCLT,COSCLT,ALP ,DALP ,
O QDATA ,QPHIS ,IDATE ,ISTP ,KTM ,KT0 ,FSECM ,FSEC0 ,
#if (defined CW)
O PA ,PB ,CWCM ,CWCP ,CVRM ,CVRP ,XMB ,CINF ,
#else
O PA ,PB ,CWCM , CVRP , CINF ,
#endif
W RAA ,RBB ,IDA ,DATA ,EDAT1 ,EDAT2 ,EDAT3 ,WDATA )
CMM W PNMGC ,DPNMGC)
C
C IMPLICIT DOUBLE PRECISION (A-H,O-Z,\)
C
C...FILE
CHARACTER*8 FILE, MODEL, RESL
CHARACTER*4 TYPE, EXPR, KTUNIT
INTEGER IMD, JMD, IMM, JMM
CHARACTER*4 NPROD, NPROM
CHARACTER*4 VCODD, VCODM
INTEGER KMD, KMM
REAL RAA(KMAX+1), RBB(KMAX+1)
CHARACTER*80 CINF2(10)
C...OUTPUT
DIMENSION QDATA(KQDMAX,MNWAV), QPHIS(2,MNWAV)
INTEGER IDATE(5)
DIMENSION PA(KMAX+1), PB(KMAX+1)
DIMENSION CWCM(IMAX*JMAX*KMAX), CVRM(IMAX*JMAX*KMAX)
#if (defined CW)
DIMENSION CWCP(IMAX*JMAX*KMAX), CVRP(IMAX*JMAX*KMAX)
DIMENSION XMB(IMAX*JMAX*KMAX)
#endif
CHARACTER*80 CINF
C...WORK
INTEGER*2 IDA(IMAX*JMAX)
REAL DATA(IMAX*JMAX)
CHARACTER* 4 LEVEL, ELEM
CHARACTER*32 TITLE
CHARACTER*16 UNIT
DIMENSION EDAT1(IMX*JMAX*KMAX)
DIMENSION EDAT2(IMX*JMAX*KMAX)
DIMENSION EDAT3(IMX*JMAX*KMAX)
DIMENSION WDATA(KMX2,MNWAV,2)
CMM DIMENSION WDATA(KMX2*MNWAV*2)
CMM DIMENSION PNMGC(MNWAV*JMAXHF), DPNMGC(MNWAV*JMAXHF)
C...INPUT
DIMENSION PNM(MNWAV,JMAXHF), IFAX(10), TRIG(IMAX), GW(JMAX)
DIMENSION SINCLT(JMAX), COSCLT(JMAX)
INTEGER LAG(MEND1,NEND1)
DIMENSION ALP(MNWAV), DALP(MNWAV)
CHARACTER*4 MWVORG,IWORG,INOUT
DATA IWORG,INOUT/'CLMN','IN '/
DATA ER/6371.D3/
C
COMMON/COMPTR/KQA ,KQB ,KQF ,KQP ,KQE ,KQZ ,
1 KQTMP,KQWV,KQROT,KQDIV,KQU ,KQV ,KQPS,KDROT,KDWV,
2 MQTMP,MQWV,MQROT,MQDIV ,MQPS
C
C =================================================================
C >>> INPUT TOPOGRAPHY FILE <<<
C =================================================================
READ(ITPGFL) MDIM
IF(MDIM.NE.MEND1) THEN
WRITE(6,*)'TOPOGRAPHY FILE IRRELEVANT MEND1,MDIM=',MEND1,MDIM
STOP 9999
END IF
CMM READ(ITPGFL) ((WDATA(K,L),K=3, 4),L=1,MNWAV)
C
C *****************************************************************
C >>> INPUT INITIAL DATA <<<
C *****************************************************************
CALL REDHED
I(NIEGFL,
O TYPE ,IDATE ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE,
O IBACK ,NNSP ,
O IMD ,JMD ,NPROD ,FLONID, FLATID,
O XID ,XJD ,XLATD ,XLOND ,
O VCODD ,KMD ,RAA ,RBB ,
O IMM ,JMM ,NPROM ,FLONIM, FLATIM,
O XIM ,XJM ,XLATM ,XLONM ,
O VCODM ,KMM ,EDAT1 ,EDAT2 ,
O CINF2 )
WRITE(6,*) IDATE, FILE,MODEL,RESL,EXPR
WRITE(CINF(1:80),'(A80)') CINF2(1) ! FOR LONG FORECAST DIVISION
C IF( FILE.NE.'INITETA ' ) THEN
C WRITE(6,*) 'FILE ERROR! THIS IS NOT INITIAL DATA'
C STOP 999
C ENDIF
IF( IMAX.NE.IMD.OR.JMAX.NE.JMD.OR.KMAX.NE.KMD ) THEN
WRITE(6,*) 'DIMENSION ERROR'
STOP 999
ENDIF
C
DO 10 K=1,KMD
PA(K)=RAA(K)
PB(K)=RBB(K)
10 CONTINUE
C
KT0=-1
ISTP=0
FSEC0=0.0
C
C =================================================================
C >>> PS <<<
C =================================================================
1100 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( IRTN.EQ.-1 ) THEN
WRITE(6,*) '*** I CANNOT FIND INITIAL DATA KT=', KTSTAR
STOP 999
ENDIF
C write(*,*)'REDIEG : KT=',KT,KTSTAR,LEVEL,' ',ELEM
IF( KT.NE.KTSTAR ) GOTO 1100
IF( LEVEL.NE.'SURF'.OR.ELEM.NE.'P ' ) GOTO 1100
C WRITE(6,*) 'REDIEG : LEVEL=',LEVEL, 'ELEM=',ELEM, DATA(10*10)
CALL RESET(EDAT1,IMAX*JMAX*KMAX)
CALL MOVERD(DATA,EDAT1,IMD*JMD)
CALL MNMX(EDAT1,IMAX*JMAX,'QPS ')
CALL RESET(WDATA,KMX2*MNWAV)
CALL G2W
I(MEND1,NEND1,JEND1,MNWAV,IMAX,JMAX,IMX ,JMAXHF, 1,
I PNM ,EDAT1,IFAX ,TRIG ,GW ,
O WDATA(1,1,2),
CMM O WDATA(KMX2*MNWAV+1),
W EDAT2)
CALL REOWAV (WDATA(1,1,2),WDATA,MEND1,NEND1,JEND1,MNWAV,
CMM CALL REOWAV (WDATA(KMX2*MNWAV+1),WDATA,MEND1,NEND1,JEND1,MNWAV,
1 2, KMX2,0, 0, 2,LAG,IWORG,INOUT)
CALL WAVMAG (WDATA,MNWAV,KMAX,'QPS ')
C
READ(ITPGFL) ((WDATA(K,L,1),K=3,4),L=1,MNWAV)
CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
1 KMX2,KQDMAX,0,KQPS, 2,LAG,IWORG,INOUT)
C
REWIND ITPGFL
IF(ITOPOG.EQ.1) THEN
CALL REOWAV (WDATA,QPHIS,MEND1,NEND1,JEND1,MNWAV,
1 KMX2, 2,2, 0, 2,LAG,MWVORG,INOUT)
ELSE
DO 100 K=1,2
DO 100 L=1,MNWAV
QPHIS(K,L)=0.0
100 CONTINUE
END IF
C
C =================================================================
C >>> U, V -> ROT, DIV <<<
C =================================================================
DO 1200 K=1,KMAX
1210 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'U ' ) GOTO 1210
CALL MOVERD(DATA,EDAT1(IMD*JMD*(K-1)+1),IMD*JMD)
1200 CONTINUE
DO 1300 K=1,KMAX
1310 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'V ' ) GOTO 1310
CALL MOVERD(DATA,EDAT2(IMD*JMD*(K-1)+1),IMD*JMD)
1300 CONTINUE
C
DO 1320 J=1,JMAXHF
CALL LGNDR1(COSCLT(J),MEND1,ALP,DALP)
DO 1330 MN=1,MNWAV
CWCM (MN+(J-1)*MNWAV)= ALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
CVRM (MN+(J-1)*MNWAV)=DALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
CMM PNMGC(MN+(J-1)*MNWAV)= ALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
CMM DPNMGC(MN+(J-1)*MNWAV)=DALP(MN)*GW(J)/(1.0-COSCLT(J)**2)
1330 CONTINUE
1320 CONTINUE
CALL G2WDZ
I(MEND1, NEND1 , JEND1, MNWAV, IMAX, JMAX , IMX , JMAXHF, KMAX,
I CWCM , CVRM , EDAT1, EDAT2, ER , SINCLT, IFAX, TRIG ,
CMM I PNMGC, DPNMGC, EDAT1, EDAT2, ER , SINCLT, IFAX, TRIG ,
O WDATA, WDATA(1,1,2),
CMM O WDATA, WDATA(KMX2*MNWAV+1),
W EDAT3)
CALL WAVMAG (WDATA,MNWAV,KMAX,'QROT')
CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
1 KMX2,KQDMAX,0,KQROT,KMX2,LAG,IWORG,INOUT)
CALL WAVMAG (WDATA(1,1,2),MNWAV,KMAX,'QDIV')
CMM CALL WAVMAG (WDATA(KMX2*MNWAV+1),MNWAV,KMAX,'QDIV')
CALL REOWAV (WDATA(1,1,2),QDATA,MEND1,NEND1,JEND1,MNWAV,
CMM CALL REOWAV (WDATA(KMX2*MNWAV+1),QDATA,MEND1,NEND1,JEND1,MNWAV,
1 KMX2,KQDMAX,0,KQDIV,KMX2,LAG,IWORG,INOUT)
C
C =================================================================
C >>> T <<<
C =================================================================
DO 1400 K=1,KMAX
1410 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'T ' ) GOTO 1410
CALL MOVERD(DATA,EDAT1(IMD*JMD*(K-1)+1),IMD*JMD)
1400 CONTINUE
CALL G2W
I(MEND1,NEND1,JEND1,MNWAV,IMAX,JMAX,IMX ,JMAXHF,KMAX,
I PNM ,EDAT1,IFAX ,TRIG ,GW ,
O WDATA,
W EDAT2)
CALL WAVMAG (WDATA,MNWAV,KMAX,'QTMP')
CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
1 KMX2,KQDMAX,0,KQTMP,KMX2,LAG,IWORG,INOUT)
C
C =================================================================
C >>> Q <<<
C =================================================================
DO 1500 K=1,KMAX
1510 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'Q ' ) GOTO 1510
CALL MOVERD(DATA,EDAT1(IMD*JMD*(K-1)+1),IMD*JMD)
C
DO 1520 I=1,IMD*JMD
IF(EDAT1(IMD*JMD*(K-1)+I).LT.0.0)
1 EDAT1(IMD*JMD*(K-1)+I)=0.0
1520 CONTINUE
1500 CONTINUE
CALL G2W
I(MEND1,NEND1,JEND1,MNWAV,IMAX,JMAX,IMX ,JMAXHF,KMAX,
I PNM ,EDAT1,IFAX ,TRIG ,GW ,
O WDATA,
W EDAT2)
CALL WAVMAG (WDATA,MNWAV,KMAX,'QWV ')
CALL REOWAV (WDATA,QDATA,MEND1,NEND1,JEND1,MNWAV,
1 KMX2,KQDMAX,0,KQWV ,KMX2,LAG,IWORG,INOUT)
#if (defined CW)
C =================================================================
C >>> CWC, CVR, XMB <<<
C =================================================================
DO 1600 K=1,KMAX
1610 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'CWC ' ) GOTO 1610
CALL MOVERD(DATA,CWCP(IMD*JMD*(K-1)+1),IMD*JMD)
CALL MOVERD(DATA,CWCM(IMD*JMD*(K-1)+1),IMD*JMD)
C
DO 1620 I=1,IMD*JMD
IF(CWCP(IMD*JMD*(K-1)+I).LT.0.0)
1 CWCP(IMD*JMD*(K-1)+I)=0.0
IF(CWCM(IMD*JMD*(K-1)+I).LT.0.0)
1 CWCM(IMD*JMD*(K-1)+I)=0.0
1620 CONTINUE
1600 CONTINUE
DO 1700 K=1,KMAX
1710 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'CVR ' ) GOTO 1710
CALL MOVERD(DATA,CVRP(IMD*JMD*(K-1)+1),IMD*JMD)
CALL MOVERD(DATA,CVRM(IMD*JMD*(K-1)+1),IMD*JMD)
C
DO 1720 I=1,IMD*JMD
IF(CVRP(IMD*JMD*(K-1)+I).LT.0.0)
1 CVRP(IMD*JMD*(K-1)+I)=0.0
IF(CVRM(IMD*JMD*(K-1)+I).LT.0.0)
1 CVRM(IMD*JMD*(K-1)+I)=0.0
1720 CONTINUE
1700 CONTINUE
DO 1800 K=1,KMAX
1810 CALL REDDAT
I(NIEGFL,
O IDATE , KT ,
O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA ,
O DATA , IRTN ,
I IMD , JMD , KMD ,
W BASE , AMP ,IDA )
IF( LEVEL.EQ.'SURF'.OR.ELEM.NE.'UMB ' ) GOTO 1810
CALL MOVERD(DATA,XMB(IMD*JMD*(K-1)+1),IMD*JMD)
C
DO 1820 I=1,IMD*JMD
IF(XMB(IMD*JMD*(K-1)+I).LT.0.0)
1 XMB(IMD*JMD*(K-1)+I)=0.0
1820 CONTINUE
1800 CONTINUE
#endif
C
C *****************************************************************
C >>> ( T - DELT T ) <<<
C *****************************************************************
C
CC IF(KTSTAR.LE.0) THEN
DO 2000 K=1,KMX2
*VOPTION INDEP
*vdir nodep
DO 2000 L=1,MNWAV
QDATA(MQTMP+K,L)=QDATA(KQTMP+K,L)
QDATA(MQROT+K,L)=QDATA(KQROT+K,L)
QDATA(MQDIV+K,L)=QDATA(KQDIV+K,L)
QDATA(MQWV +K,L)=QDATA(KQWV +K,L)
2000 CONTINUE
DO 2010 K=1, 2
*VOPTION INDEP
*vdir nodep
DO 2010 L=1,MNWAV
QDATA(MQPS +K,L)=QDATA(KQPS +K,L)
2010 CONTINUE
CC ENDIF
C
RETURN
END SUBROUTINE REDIEG