var/convertor/kma_wave2grid/REDIEG.inc

   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