var/convertor/wave2grid_kma/PREGSM.inc

   1       SUBROUTINE PREGSM(PSE,GTE,GUE,GVE,GQE,PSB,GTB,GUB,GVB,GQB,
   2      &          IMAXE,JMAXE,ISST,JSST,MAXJZ,IVAR,
   3      &          IMAX,JMAX,KMAX,IDIM,JDIM,MEND1,NEMD1,JEND1,
   4      &          ISNW,JSNW,JMAXHF,MNWAV,IMX)
   5       INTEGER IDATE(5), IDGES(5), IDSST(5)
   6       CHARACTER*8 FILE, MODEL0, RESL0
   7       CHARACTER*80 CINF0(10)
   8       CHARACTER*4 TYPE, EXPR0, KTUNIT, NPROD, NPROM, VCODD, VCODM
   9       CHARACTER*4 LEVEL, ELEM
  10       CHARACTER*32 TITLE
  11       CHARACTER*16 UNIT
  12       CHARACTER*8 MDLINF(4)
  13 ! modified by shc p1 start
  14       CHARACTER*80 CINF0_X(10),CINF_temp
  15       CHARACTER*4 VCODD_X, VCODM_X
  16 ! modified by shc p1 end
  17       REAL        DTHPRO(7)
  18       INTEGER ITYP(2)
  19       CHARACTER*48 LABEL
  20       INTEGER JTINF(2)
  21           CHARACTER*10  FROMUNPACK
  22           INTEGER               IUNPACK
  23 C
  24       DIMENSION A(KMAX+1), B(KMAX+1), AAM(KMAX+1), BBM(KMAX+1)
  25       DIMENSION AGD(KMAX+1), BGD(KMAX+1), AGM(KMAX+1), BGM(KMAX+1)
  26       DIMENSION GPHIS(IMAX*JMAX)
  27       REAL, DIMENSION(IMAX,JMAX)    :: GAU
  28
  29       DIMENSION PSE (IMAXE,JMAXE),
  30      1       GZE (IMAXE,JMAXE,KMAX), GTE  (IMAXE,JMAXE,KMAX),
  31      2       GUE (IMAXE,JMAXE,KMAX), GVE  (IMAXE,JMAXE,KMAX),
  32      3       GQE (IMAXE,JMAXE,KMAX)
  33       DIMENSION  PS  (IMAX,JMAX),  GRH (IMAX,JMAX,KMAX),
  34      1       GZ  (IMAX,JMAX,KMAX), GT  (IMAX,JMAX,KMAX),
  35      2       GU  (IMAX,JMAX,KMAX), GV  (IMAX,JMAX,KMAX),
  36      3       GQ  (IMAX,JMAX,KMAX), AGT (IMAX,JMAX,KMAX),
  37      4       GCWC(IMAX,JMAX,KMAX), GCVR(IMAX,JMAX,KMAX),
  38      5       GUMB(IMAX,JMAX,KMAX),
  39      6       GSST(IMAX,JMAX)     , GSNW(IMAX,JMAX)
  40       DIMENSION  PSB (IMAX,JMAX),  GRHB(IMAX,JMAX,KMAX),
  41      1       GQB (IMAX,JMAX,KMAX), GTB (IMAX,JMAX,KMAX),
  42      2       GUB (IMAX,JMAX,KMAX), GVB (IMAX,JMAX,KMAX)
  43       real   rdum (imax,jmax,kmax)
  44 !modified by shc AB start
  45       INTEGER MMM0(5)
  46 !modified by shc AB end
  47
  48       DIMENSION VLG(IMAX,JMAX,KMAX)
  49 C     DIMENSION WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX),
  50       REAL * 8  WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX)
  51       DIMENSION WRK3(IMAX,JMAX,KMAX), WRK4(IMAX,JMAX,KMAX),
  52      2          WRK5(IMAX,JMAX,KMAX), WRK6(IMAX,JMAX,KMAX)
  53       CHARACTER*4 ALVL
  54 !modified by shc I2 start
  55 c     INTEGER*2 I2(IDIM*JDIM)     !shc-rizvi
  56       INTEGER   I2(IDIM*JDIM/2)   !shc-rizvi
  57 !modified by shc I2 end
  58       REAL*8    WRK(IDIM,JDIM)
  59       DIMENSION SSTA(ISST*JSST), SEWA(ISNW,JSNW)
  60       DIMENSION COLRAD(JMAX), DY(JMAX), LY(JMAX)
  61       DIMENSION WORK(362,182),DP(4,IMAX,JMAX)
  62       INTEGER*2 IP(2,IMAX,JMAX)
  63       REAL*8    GAUL(JMAX),GAUW(JMAX),COCOT(JMAX)
  64       COMMON/CTETEN/TABLE(25000)
  65       COMMON/DTETEN/DTABLE(25000)
  66       REAL*8 TABLE,DTABLE,RGSA
  67       DIMENSION RLAT(MAXJZ), ZDAT(MAXJZ,KMAX)
  68 C
  69       NAMELIST /NAMFIL0/NALFL0,NVPFL0,NGSFL0,NSSTFL0,NSNWFL0,NINFL0,
  70      1              KTLAG0,IDCHCK0,NDIGFL0,NTPFL0,NALOT0,NRSFL0
  71 C     NAMELIST /HEADIN/ TYPE,FILE,KTUNIT,IDTYPE,
  72 C    1                  IBACK,NNSP
  73 C------------------------------------------------------------------------
  74 C  NALFL : 3DOI INPUT FILE
  75 C  NVPFL : VERTIAL LEVEL DEF. FILE
  76 C  NTPFL : TOPO FILE
  77 C  NALOT : 3DOI INPUT SAVE FILE
  78 C  NRSFL : UNPACK INPUT FILE
  79 C------------------------------------------------------------------------
  80       NAMELIST /NAMVER0/ MODEL0, RESL0, EXPR0, CINF0
  81
  82       DATA RHMIN/1.0E-3/
  83       DATA TLAPS,QCONS,QMIN,KST,ITERMX/2.0E-3,2.5E-6,1.0E-10,10,3/
  84 C
  85       DATA NALFL0,NGSFL0,NSSTFL0,NSNWFL0,NINFL0,NVPFL0,NALOT0,NRSFL0
  86      1    /     1,     2,    -1,    -1,    11,    21,   12,   -1/
  87       DATA KTLAG0 / 6/
  88       DATA IDCHCK0/ 1/
  89 !modified by shc AB start
  90 c  The definition A and B by 'DATA' was removed
  91 !modified by shc AB end
  92 !modified by shc AB start
  93       READ(115) MMM0,MMM1,MMM2,FFF1,MMM3,MMM4,
  94      1                      (A(K),K=1,MMM4),(B(K),K=1,MMM4)
  95       A(KMAX+1)=0.0; B(KMAX+1)=0.0
  96 !modified by shc AB end
  97 C
  98 C   =================================================================
  99 C   >>>   READ ANAL TIME                                          <<<
 100 C   =================================================================
 101           READ(94,'(I4,3I2)') (IDATE(I),I=1,4)
 102           IDATE(5)=0
 103 C   =================================================================
 104 C   >>>   NAMELIST (NAMFIL)                                       <<<
 105 C   =================================================================
 106       READ(96,NAMFIL0)
 107 c     READ(96,HEADIN)
 108       WRITE(6,NAMFIL0)
 109 c     WRITE(6,HEADIN)
 110 !modified by shc p1 start
 111       LARHM=20
 112 !modified by shc p1 end
 113 C   =================================================================
 114 C   >>>   Select Input Source                                     <<<
 115 C   =================================================================
 116 !shc-wei start
 117 c     CALL GETENV('FROMUNPACK',FROMUNPACK)
 118 c     IF (LEN_TRIM(FROMUNPACK).EQ.0) THEN
 119 c       IUNPACK=0
 120 c     ELSE
 121 c       READ(FROMUNPACK,'(I1)') IUNPACK
 122 c     END IF
 123 c     WRITE(6,*)'IUNPACK=',IUNPACK
 124 !shc-wei end
 125 C   =================================================================
 126 C   >>>   GENERATE GAUSSIAN LATITUDES                             <<<
 127 C   =================================================================
 128       CALL GAUSS(GAUL,GAUW,JMAX)
 129       DO 800 J=1,JMAX
 130       COLRAD(J)=ACOS(GAUL(J))
 131   800 CONTINUE
 132       CALL ZMNLAT( RLAT, MAXJZ, COLRAD, JMAX )
 133 C
 134 C   =================================================================
 135 C   >>>   TETEN                                                   <<<
 136 C   =================================================================
 137       ICE = 1
 138       CALL TETEN(ICE)
 139 C   =================================================================
 140 C   >>>  READ TOPO FILE
 141 C   =================================================================
 142           NTPFL0 = 3
 143 c         go to 33333     !shc For T63 only
 144           IF (NTPFL0.GT.0) THEN
 145                 READ(NTPFL0)NWV,DUM,IGRD,JGRD
 146                 IF ((IGRD.NE.IMAX).OR.(JGRD.NE.JMAX)) THEN
 147                         WRITE(*,*)' TOPO DIM DOES NOT MATCH'
 148                         WRITE(*,*)'IMAX=',IMAX,' IGRD=',IGRD
 149                         WRITE(*,*)'JMAX=',JMAX,' JGRD=',JGRD
 150                         STOP 9988
 151                 END IF
 152                 READ(NTPFL0)
 153                 READ(NTPFL0)
 154                 READ(NTPFL0)GPHIS
 155                 WRITE(*,*)'GRID DISTANCE=',DUM
 156           END IF
 157 C---------------------------------------------------------------------
 158 C +++ CONVERT LAT/LON to GAUSS
 159 C---------------------------------------------------------------------
 160 33333        continue
 161 c       READ(NTPFL0,'(10f10.3)')GPHIS    !shc For T63 only
 162         CALL LT2GAU (PSE,IMAXE,JMAXE,IMAX,JMAX,
 163      1                  COLRAD,PS,DY,LY)
 164        DO K = 1, KMAX
 165         CALL LT2GAU (GTE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
 166      1                  COLRAD,GT(:,:,K),DY,LY)
 167         CALL LT2GAU (GUE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
 168      1                  COLRAD,GU(:,:,K),DY,LY)
 169         CALL LT2GAU (GVE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
 170      1                  COLRAD,GV(:,:,K),DY,LY)
 171         CALL LT2GAU (GQE(:,:,K),IMAXE,JMAXE,IMAX,JMAX,
 172      1                  COLRAD,GQ(:,:,K),DY,LY)
 173        ENDDO
 174 9001   format(10e15.7)
 175        rdum = 0.0
 176        write(902,9001) ((rdum(i,j,1),i=1,imax),j=1,jmax)
 177        write(902,9001) ((PS(i,j),i=1,imax),j=1,jmax)
 178        write(902,9001) ((rdum(i,j,1),i=1,imax),j=1,jmax)
 179        do k=1,kmax
 180        write(902,9001) ((GT(i,j,k),i=1,imax),j=1,jmax)
 181        enddo
 182        do k=1,kmax
 183        write(902,9001) ((GU(i,j,k),i=1,imax),j=1,jmax)
 184        enddo
 185        do k=1,kmax
 186        write(902,9001) ((GV(i,j,k),i=1,imax),j=1,jmax)
 187        enddo
 188        do k=1,kmax
 189        write(902,9001) ((GQ(i,j,k),i=1,imax),j=1,jmax)
 190        enddo
 191        do k=1,kmax
 192        write(902,9001) ((rdum(i,j,k),i=1,imax),j=1,jmax)
 193        enddo
 194        do k=1,kmax
 195        write(902,9001) ((rdum(i,j,k),i=1,imax),j=1,jmax)
 196        enddo
 197 C
 198 C   =================================================================
 199 C   >>>   PS, TEMP, Q -> RH
 200 C   =================================================================
 201       CALL RELHUM
 202      I  (GT ,GQ ,PS ,IMAX,JMAX,KMAX,A,B,
 203      O   GRH)
 204       CALL RELHUM
 205      I  (GTB ,GQB ,PSB ,IMAX,JMAX,KMAX,A,B,
 206      O   GRHB)
 207       PIHF = pi*0.5
 208       DO 3739 K = 1,KMAX
 209       DO 3738 J = 1,JMAX
 210       DO 3737 I = 1,IMAX
 211         AANAL = GRH(I,J,K)-GRHB(I,J,K)
 212         AGES  = GRHB(I,J,K)
 213         IF    ( AGES.LE.0.0 .AND. AANAL.LE.0.0 ) THEN
 214            AANAL = 1.0E-6
 215         ELSEIF( AGES.GE.1.0 .AND. AANAL.GE.0.0 ) THEN
 216            AANAL = 1.0
 217         ELSE
 218           IF( AANAL.GT.0.0 ) THEN
 219             RES = 1.0-AGES
 220           ELSE
 221             RES =    -AGES
 222           ENDIF
 223           IF( ABS(AANAL).LE.ABS(RES*0.5) ) THEN
 224             AANAL = AGES+AANAL
 225           ELSE
 226             AA = RES/PIHF*0.5
 227             XN = AANAL-RES*0.5
 228             AANAL        = AGES + 0.5*RES + AA*ATAN(XN/AA)
 229           ENDIF
 230         ENDIF
 231         AANAL        = MAX( AANAL, 1.0E-6 )
 232         AANAL        = MIN( AANAL, 1.0E0  )
 233         GRH(I,J,K) = AANAL
 234  3737 CONTINUE
 235  3738 CONTINUE
 236  3739 CONTINUE
 237
 238 C   =================================================================
 239 C   >>>   PS, TEMP, Q -> Z
 240 C   =================================================================
 241       CALL GPLHGT
 242      I  (PS,GT,GQ,GPHIS,IMAX,JMAX,KMAX,gas_constant,gravity,A,B,
 243      I      1,JMAX,
 244      O   GZ)
 245
 246 CLSW   do k=1,22,3
 247 CLSW    do j=1,jmax
 248 CLSW      write(99,FMT='(10F12.5,1x)') (GZ(I,J,K),I=1,IMAX)
 249 CLSW    enddo
 250 CLSW   enddo
 251 C  ==================================================================
 252 C  >>> SAVE INPUT DATA
 253 C  ==================================================================
 254         IF (NALOT0.GT.0) THEN
 255             WRITE(NALOT0)PS
 256             WRITE(NALOT0)GZ
 257             WRITE(NALOT0)GU
 258             WRITE(NALOT0)GV
 259             WRITE(NALOT0)GQ
 260             WRITE(NALOT0)GT
 261         END IF
 262 Crizvi      ELSE          ! START WITH UNPACK FILE
 263 Crizvi        LARHM=20
 264 Crizvi        READ(NRSFL0)IDATE
 265 Crizvi        READ(NRSFL0)PS
 266 Crizvi        READ(NRSFL0)GZ
 267 Crizvi        READ(NRSFL0)GU
 268 Crizvi        READ(NRSFL0)GV
 269 Crizvi        READ(NRSFL0)GQ
 270 Crizvi        READ(NRSFL0)AGT
 271 Crizvi
 272 Crizvi      END IF ! READ ANAL FINISH
 273        print*,' Gaussian lats data size ',IMAX, JMAX, KMAX
 274         write(661,'(10f10.3)')PS
 275         write(661,'(10f10.3)')GU
 276         write(661,'(10f10.3)')GV
 277         write(661,'(10f10.3)')GT
 278         write(661,'(10f10.3)')GQ
 279
 280 CLSW      write(99,*) ' Gauss GT'
 281 CLSW   do k=1,2
 282 CLSW    do j=1,jmax
 283 CLSW      write(99,FMT='(10F12.5,1x)') (GT(I,J,k),I=1,IMAX)
 284 CLSW    enddo
 285 CLSW   enddo
 286 C---------------------------------------------------------------------
 287 C      DO J = 1, JMAX
 288 C        write(99,FMT='(10F12.5,1x)') (GAU(I,J),I=1,IMAX)
 289 C      ENDDO
 290
 291 1000  CONTINUE
 292
 293 C   =================================================================
 294 C   >>>   NAMELIST (NAMVER)                                       <<<
 295 C   =================================================================
 296       CINF0(1)=' ';CINF0(2)=' ';CINF0(3)=' ';CINF0(4)=' ';CINF0(5)=' '
 297       CINF0(6)=' ';CINF0(7)=' ';CINF0(8)=' ';CINF0(9)=' ';CINF0(10)=' '
 298       READ(96,NAMVER0)
 299       WRITE(6,NAMVER0)
 300 C   =================================================================
 301       IF(NGSFL0.GE.0) THEN
 302       CALL REDGES
 303      I(NGSFL0 ,IMAX  ,JMAX  ,KMAX  ,KTLAG0 ,IDATE ,IDCHCK0,
 304      O IDGES ,AGD   ,BGD   ,AGM   ,BGM   ,GCWC  ,GCVR  ,GUMB  ,
 305      W I2    ,IDSST )
 306       ENDIF
 307 !modified by shc ZT start
 308       goto 7700
 309 !modified by shc ZT end
 310 C   =================================================================
 311 C   >>>   Z -> TV                                                 <<<
 312 C   =================================================================
 313 C     CALL CTIME( 4, 'ZE2TVE              ' )
 314 C   >>> GT IS TV (OUTPUT)
 315       IF (NTPFL0.LT.0) THEN
 316         CALL GH2TV(GZ, GT, PS, GPHIS, A, B,
 317      1          IMAX  , JMAX  , KMAX  ,WRK1  , WRK2  , WRK3  , WRK4)
 318       ELSE
 319         CALL ZE2TVE( GZ    , GT    , PS    , A     , B     ,
 320      I             IMAX  , JMAX  , KMAX  ,
 321      W             VLG   , WRK1  , WRK2  , WRK3  , WRK4  , WRK5  ,
 322      W             WRK6  )
 323 C
 324 CLSW      write(99,*) ' Z->TV'
 325 CLSW   do k=1,2
 326 CLSW    do j=1,jmax
 327 CLSW      write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX)
 328 CLSW    enddo
 329 CLSW   enddo
 330       END IF
 331 CLSW  CALL ZMNT( ZDAT, MAXJZ, KMAX, GT   , IMAX, JMAX )
 332 CLSW  CALL OUTZ( ZDAT, MAXJZ, KMAX, 'TV  ',
 333 CLSW 1            'TV                             ', 'K               ',
 334 CLSW 2             0, RLAT, 'KMAX' )
 335
 336 C   =================================================================
 337 C   >>>   RH, TV -> Q, T                                          <<<
 338 C   =================================================================
 339       IDX=1
 340       LARHM=20
 341       DO K=1,LARHM-1
 342       DO I=1,IMAX
 343       DO J=1,JMAX
 344        GQ(I,J,K)=GRH(I,J,K)
 345       ENDDO
 346       ENDDO
 347       ENDDO
 348       CALL CRH2SHA
 349      I(IMAX*JMAX, KMAX, PS, A, B, gravity,gas_constant,
 350      I TLAPS,QCONS,QMIN,KST,ITERMX,
 351      I IDX, LARHM,
 352      O GQ, GT)
 353 C          write(99,*) ' after  RH, TV -> Q, T'
 354 C       do k=1,2
 355 C        do j=1,jmax
 356 C          write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX)
 357 C        enddo
 358 C       enddo
 359 !modified by shc ZT start
 360 7700   continue
 361 !modified by shc ZT end
 362
 363 !modified by shc q0 start
 364       DO I=1,IMAX
 365       DO J=1,JMAX
 366       DO K=1,KMAX
 367         IF (GQ(I,J,K).LT.0.00) GQ(I,J,K)=1.E-06
 368       ENDDO
 369       ENDDO
 370       ENDDO
 371       print *, 'shcimsi q0=',1.E-06
 372 !modified by shc q0 end
 373
 374 !modified by shc p1 start
 375       NANFL=151
 376       KT=0
 377       DO i=1,80
 378         CINF_temp(i:i)=' '
 379       ENDDO
 380       DO j=1,10
 381         CINF0_X(j)=CINF_temp
 382       ENDDO
 383       VCODD_X='    '
 384       VCODM_X='    '
 385       CALL WRTHED
 386      I(NANFL ,
 387      I 'GVS1',IDATE ,'ANALETA ','GANL9603','T213L30L',
 388      I 'R03 ','HOUR',1     ,0     ,0     ,
 389      I IMAX  ,JMAX  ,'GAUS', 0.0 , 0.0,
 390      I 0.0   ,0.0, 0.0   ,0.0   ,
 391      I VCODD_X,KMAX  ,A     ,B     ,
 392      I IMAX  ,JMAX  ,'GAUS', 0.0 , 0.0,
 393      I 0.0   ,0.0, 0.0   ,0.0   ,
 394      I VCODM_X,KMAX  ,A     ,B     ,
 395      I CINF0_X )
 396
 397       GPHIS(:)=GPHIS(:)/G
 398       CALL MOVERD(GPHIS, WRK, IMAX*JMAX)
 399       CALL WRTDAT
 400      1(NANFL , IDATE , KT    , 'SURF', 'TOPO',
 401      2 'GEOPOTENTIAL HEIGHT             ', 'M               ',
 402      3 0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 403
 404       CALL MOVERD(PS, WRK, IMAX*JMAX)
 405       CALL WRTDAT
 406      1(NANFL , IDATE , KT    , 'SURF', 'P   ',
 407      2 'SURFACE PRESSURE                ', 'HPA             ',
 408      3 0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 409
 410       CALL MOVERD(GU(1,1,1), WRK, IMAX*JMAX)
 411       CALL WRTDAT
 412      1(NANFL , IDATE , KT    , 'SURF', 'U   ',
 413      2 'SURFACE U                       ', 'M/S             ',
 414      3 0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 415
 416       CALL MOVERD(GV(1,1,1), WRK, IMAX*JMAX)
 417       CALL WRTDAT
 418      1(NANFL , IDATE , KT    , 'SURF', 'V   ',
 419      2 'SURFACE V                       ', 'M/S             ',
 420      3 0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 421
 422       CALL MOVERD(GT(1,1,1), WRK, IMAX*JMAX)
 423       CALL WRTDAT
 424      1(NANFL , IDATE , KT    , 'SURF', 'T   ',
 425      2 'SURFACE T                       ', 'K               ',
 426      3 0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 427
 428       CALL MOVERD(GRH(1,1,1), WRK, IMAX*JMAX)
 429       CALL WRTDAT
 430      1(NANFL , IDATE , KT    , 'SURF', 'RH  ',
 431      2 'SURFACE RELATIVE HUMIDITY       ', '0-1             ',
 432      3 0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 433
 434       DO K=1,KMAX
 435         CALL MOVERD(GU(1,1,K), WRK, IMAX*JMAX)
 436         WRITE(ALVL(1:4), '(I4)') K
 437         CALL WRTDAT
 438      1  (NANFL , IDATE , KT    ,  ALVL, 'U   ',
 439      2   'U                               ', 'M/S             ',
 440      3   0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 441       ENDDO
 442
 443       DO K=1,KMAX
 444         CALL MOVERD(GV(1,1,K), WRK, IMAX*JMAX)
 445         WRITE(ALVL(1:4), '(I4)') K
 446         CALL WRTDAT
 447      1  (NANFL , IDATE , KT    ,  ALVL, 'V   ',
 448      2   'V                               ', 'M/S             ',
 449      3   0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 450       ENDDO
 451
 452       DO K=1,KMAX
 453         CALL MOVERD(GZ(1,1,K), WRK, IMAX*JMAX)
 454         WRITE(ALVL(1:4), '(I4)') K
 455         CALL WRTDAT
 456      1  (NANFL , IDATE , KT    ,  ALVL, 'Z   ',
 457      2   'GEOPOTENTIAL HEIGHT             ', 'M               ',
 458      3   0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 459       ENDDO
 460
 461       DO K=1,KMAX
 462         CALL MOVERD(GT(1,1,K), WRK, IMAX*JMAX)
 463         WRITE(ALVL(1:4), '(I4)') K
 464         CALL WRTDAT
 465      1  (NANFL , IDATE , KT    ,  ALVL, 'T   ',
 466      2   'TEMPERATURE                     ', 'K               ',
 467      3   0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 468       ENDDO
 469
 470       DO K=1, LARHM-1
 471         CALL MOVERD(GRH(1,1,K), WRK, IMAX*JMAX)
 472         WRITE(ALVL(1:4), '(I4)') K
 473         CALL WRTDAT
 474      1  (NANFL , IDATE , KT    ,  ALVL, 'RH  ',
 475      2   'RELATIVE HUMIDITY               ', '0-1             ',
 476      3   0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 477       ENDDO
 478
 479       DO K=LARHM,KMAX
 480         CALL MOVERD(GQ(1,1,K), WRK, IMAX*JMAX)
 481         WRITE(ALVL(1:4), '(I4)') K
 482         CALL WRTDAT
 483      1  (NANFL , IDATE , KT    ,  ALVL, 'Q   ',
 484      2   'SPECIFIC HUMIDITY               ', 'KG/KG           ',
 485      3   0     , 0     ,WRK  , IMAX  , JMAX  , I2    )
 486       ENDDO
 487       WRITE(NANFL) IDATE,KT,0,'    ','    '
 488 !modified by shc p1 end
 489
 490        rdum = 0.0
 491        write(903,9001) ((rdum(i,j,1),i=1,imax),j=1,jmax)
 492        write(903,9001) ((PS(i,j),i=1,imax),j=1,jmax)
 493        write(903,9001) ((rdum(i,j,1),i=1,imax),j=1,jmax)
 494        do k=1,kmax
 495        write(903,9001) ((GT(i,j,k),i=1,imax),j=1,jmax)
 496        enddo
 497        do k=1,kmax
 498        write(903,9001) ((GU(i,j,k),i=1,imax),j=1,jmax)
 499        enddo
 500        do k=1,kmax
 501        write(903,9001) ((GV(i,j,k),i=1,imax),j=1,jmax)
 502        enddo
 503        do k=1,kmax
 504        write(903,9001) ((GQ(i,j,k),i=1,imax),j=1,jmax)
 505        enddo
 506        do k=1,kmax
 507        write(903,9001) ((rdum(i,j,k),i=1,imax),j=1,jmax)
 508        enddo
 509        do k=1,kmax
 510        write(903,9001) ((rdum(i,j,k),i=1,imax),j=1,jmax)
 511        enddo
 512 C   *****************************************************************
 513 C   >>>   OUTPUT INITIAL VALUE                                    <<<
 514 C   *****************************************************************
 515 C   =================================================================
 516 C   >>>   HEADER                                                  <<<
 517 C   =================================================================
 518       CALL WRTHED
 519      I(NINFL0 ,
 520      I 'GVS1',IDATE ,'INITETA ',MODEL0, RESL0,
 521      I EXPR0 ,'HOUR',1     ,0     ,0     ,
 522      I IMAX  ,JMAX  ,'GAUS',360.0/IMAX, REAL(JMAX),
 523      I 1.0   ,(JMAX+1)/2.0, 0.0   ,0.0   ,
 524      I 'ETA ',KMAX  ,A     ,B     ,
 525      I IMAX  ,JMAX  ,'GAUS',360.0/IMAX, REAL(JMAX),
 526      I 1.0   ,(JMAX+1)/2.0, 0.0   ,0.0   ,
 527      I 'ETA ',KMAX  ,A     ,B     ,
 528      I CINF0 )
 529 C
 530 C   =================================================================
 531 C   >>>   PS                                                      <<<
 532 C   =================================================================
 533       CALL MOVERD(PS, WRK, IMAX*JMAX)
 534       CALL WRTDAT
 535      1(NINFL0 , IDATE , -1    , 'SURF', 'P   ',
 536      2 'P                               ', 'HPA             ',
 537      3 0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 538 C
 539 C   =================================================================
 540 C   >>>   U, V                                                    <<<
 541 C   =================================================================
 542         DO 9030 K=1,KMAX
 543         CALL MOVERD(GU(1,1,K), WRK, IMAX*JMAX)
 544         WRITE(ALVL(1:4), '(I4)') K
 545         CALL WRTDAT
 546      1  (NINFL0 , IDATE , -1    , ALVL  , 'U   ',
 547      2   'U                               ', 'M/S             ',
 548      3   0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 549  9030   CONTINUE
 550         DO 9040 K=1,KMAX
 551         CALL MOVERD(GV(1,1,K), WRK, IMAX*JMAX)
 552         WRITE(ALVL(1:4), '(I4)') K
 553         CALL WRTDAT
 554      1  (NINFL0 , IDATE , -1    , ALVL  , 'V   ',
 555      2   'V                               ', 'M/S             ',
 556      3   0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 557  9040   CONTINUE
 558 C   =================================================================
 559 C   >>>   T, Q                                                    <<<
 560 C   =================================================================
 561         DO 9010 K=1,KMAX
 562         CALL MOVERD(GT(1,1,K), WRK, IMAX*JMAX)
 563         WRITE(ALVL(1:4), '(I4)') K
 564         CALL WRTDAT
 565      1  (NINFL0 , IDATE , -1    , ALVL  , 'T   ',
 566      2   'T                               ', 'K               ',
 567      3   0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 568  9010   CONTINUE
 569         DO 9020 K=1,KMAX
 570         CALL MOVERD(GQ(1,1,K), WRK, IMAX*JMAX)
 571         WRITE(ALVL(1:4), '(I4)') K
 572         CALL WRTDAT
 573      1  (NINFL0 , IDATE , -1    , ALVL  , 'Q   ',
 574      2   'Q                               ', 'KG/KG           ',
 575      3   0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 576  9020   CONTINUE
 577 C   =================================================================
 578 C   >>>  SAVE INPUT FIELD FOR DIAG.
 579 C   =================================================================
 580       IF (NDIGFL0.GT.0) THEN
 581         WRITE(NDIGFL0)GT
 582         WRITE(NDIGFL0)GQ
 583       END IF
 584 C
 585 C   =================================================================
 586 C   >>>   CWC, CVR                                                <<<
 587 C   =================================================================
 588       IF(NGSFL0.GT.0) THEN
 589         DO 9050 K=1,KMAX
 590         CALL MOVERD(GCWC(1,1,K), WRK, IMAX*JMAX)
 591         WRITE(ALVL(1:4), '(I4)') K
 592         CALL WRTDAT
 593      1  (NINFL0 , IDATE , -1    , ALVL  , 'CWC ',
 594      2   'CLOUD WATER CONTENT             ', 'KG/KG           ',
 595      3   0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 596  9050   CONTINUE
 597         DO 9060 K=1,KMAX
 598         CALL MOVERD(GCVR(1,1,K), WRK, IMAX*JMAX)
 599         WRITE(ALVL(1:4), '(I4)') K
 600         CALL WRTDAT
 601      1  (NINFL0 , IDATE , -1    , ALVL  , 'CVR ',
 602      2   'CLOUD COVER                     ', '-               ',
 603      3   0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 604  9060   CONTINUE
 605 C
 606 C   =================================================================
 607 C   >>>   UMB                                                     <<<
 608 C   =================================================================
 609         DO 9070 K=1,KMAX
 610         CALL MOVERD(GUMB(1,1,K), WRK, IMAX*JMAX)
 611         WRITE(ALVL(1:4), '(I4)') K
 612         CALL WRTDAT
 613      1  (NINFL0 , IDATE , -1    , ALVL  , 'UMB ',
 614      2   'UPWARD MASS FLUX AT CLOUD BASE  ', 'KG/S/M**2       ',
 615      3   0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 616  9070   CONTINUE
 617       END IF   !NGSFL>0
 618 C
 619 C   *****************************************************************
 620 C   >>>   SST ANOMALY                                             <<<
 621 C   *****************************************************************
 622       IF( NSSTFL0.NE.-1 ) THEN
 623       CALL GETTYP(NSSTFL0,IOTYP)
 624 C
 625       IF(IOTYP.EQ.1) THEN
 626 C     CALL GVDFIR(NSSTFL0,
 627 C    1            IDSST,IBACK,IM,JM,MDLINF,DTHPRO,CINF0,ITYP,IRTN)
 628 C     WRITE(6,*) 'GVDFIR:IRTN=',IRTN
 629 C     CALL GVDFNR(NSSTFL0,IDSST,0,'SURF','SSTA',
 630 C    1            LABEL,JTINF,SSTA,IRTN)
 631 C     WRITE(6,*) 'GVDFNR:IRTN=',IRTN
 632       WRITE(*,*)' UNKNOWN IOTYP:1'
 633       STOP 9999
 634       ELSE IF(IOTYP.EQ.3) THEN
 635 C   =================================================================
 636 C   >>>   HEADER                                                  <<<
 637 C   =================================================================
 638       CALL REDHED
 639      I(NSSTFL0,
 640      O TYPE  ,IDSST ,FILE  ,MODEL0,RESL0 ,EXPR0 ,KTUNIT,IDTYPE,
 641      O IBACK ,NNSP  ,
 642      O IMD   ,JMD   ,NPROD ,FLONID, FLATID,
 643      O XID   ,XJD   ,XLATD ,XLOND ,
 644      O VCODD ,KMD   ,A     ,B     ,
 645      O IMM   ,JMM   ,NPROM ,FLONIM, FLATIM,
 646      O XIM   ,XJM   ,XLATM ,XLONM ,
 647      O VCODM ,KMM   ,AAM   ,BBM   ,
 648      O CINF0 )
 649 C   =================================================================
 650 C   >>>   SST ANOMALLY                                            <<<
 651 C   =================================================================
 652       DO 1 I=1,NNSP
 653         READ(NSSTFL0)
 654     1 CONTINUE
 655  3001 CALL REDDAT
 656      I(NSSTFL0,
 657      O IDSST , KT    ,
 658      O LEVEL , ELEM  , TITLE , UNIT  , KTSD  , KTSA  ,
 659      O SSTA  , IRTN  ,
 660      I ISST  , JSST  , 1     ,
 661      W BASE  , AMP   ,I2    )
 662       IF(ELEM.NE.'SSTA') GOTO 3001
 663       WRITE(6,*) '## ', TITLE, '(',UNIT,')'
 664       ENDIF
 665 C
 666       WRITE(6,*) '## ', IDSST, KT
 667       IF( IDCHCK0.EQ.1 ) THEN
 668         CALL CVDATE( IDGES, IDSST, 24 )
 669         IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR.
 670      1      IDATE(3).NE.IDGES(3) ) THEN
 671           WRITE(6,*) 'SSTA : DATE CHECK ERROR'
 672           STOP 999
 673         ENDIF
 674       ENDIF
 675 C
 676       CALL LT2GAU(SSTA,ISST,JSST,IMAX,JMAX,COLRAD,GSST,DY,LY)
 677       CALL MOVERD(GSST, WRK, IMAX*JMAX)
 678       CALL WRTDAT
 679      1(NINFL0 , IDATE , -1    , 'SURF', 'SSTA',
 680      2 'SST ANOMALLY                    ', 'K               ',
 681      3 0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 682       WRITE(6,*) '## SST ANOMALLY WAS WRITTEN'
 683 C
 684       ENDIF
 685 C
 686 C   *****************************************************************
 687 C   >>>   SNOW ANALYSIS                                           <<<
 688 C   *****************************************************************
 689       IF( NSNWFL0.NE.-1 ) THEN
 690 C   =================================================================
 691 C   >>>   HEADER                                                  <<<
 692 C   =================================================================
 693       CALL REDHED
 694      I(NSNWFL0,
 695      O TYPE  ,IDSST ,FILE  ,MODEL0,RESL0 ,EXPR0 ,KTUNIT,IDTYPE,
 696      O IBACK ,NNSP  ,
 697      O IMD   ,JMD   ,NPROD ,FLONID, FLATID,
 698      O XID   ,XJD   ,XLATD ,XLOND ,
 699      O VCODD ,KMD   ,A     ,B     ,
 700      O IMM   ,JMM   ,NPROM ,FLONIM, FLATIM,
 701      O XIM   ,XJM   ,XLATM ,XLONM ,
 702      O VCODM ,KMM   ,AAM   ,BBM   ,
 703      O CINF0 )
 704       DO 2 I=1,NNSP
 705         READ(NSNWFL0)
 706     2 CONTINUE
 707 C   =================================================================
 708 C   >>>   SNOW ANALYSIS                                           <<<
 709 C   =================================================================
 710       CALL REDDAT
 711      I(NSNWFL0,
 712      O IDSST , KT    ,
 713      O LEVEL , ELEM  , TITLE , UNIT  , KTSD  , KTSA  ,
 714      O SEWA  , IRTN  ,
 715      I ISNW  , JSNW  , 1     ,
 716      W BASE  , AMP   ,I2    )
 717       WRITE(6,*) '## ', TITLE, '(',UNIT,')'
 718       WRITE(6,*) '## ', IDSST, KT
 719       IF( IDCHCK0.EQ.1 ) THEN
 720         CALL CVDATE( IDGES, IDSST, 24 )
 721         IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR.
 722      1      IDATE(3).NE.IDGES(3) ) THEN
 723           WRITE(6,*) 'SNOW : DATE CHECK ERROR'
 724           STOP 999
 725         ENDIF
 726       ENDIF
 727 C   -----
 728       CALL SETWHT (IMAX,JMAX,DP,IP,GAUL,GAUW,COCOT)
 729       DO 100 J=1,180
 730       DO 100 I=1,360
 731       WORK(I+1,J+1)=SEWA(I,J)
 732   100 CONTINUE
 733       DO 200 J=1,180
 734       WORK(  1,J+1)=WORK(361,J+1)
 735       WORK(362,J+1)=WORK(  2,J+1)
 736   200 CONTINUE
 737       DO 300 I=1,362
 738       WORK(I,  1)=WORK(I,  2)
 739       WORK(I,182)=WORK(I,181)
 740   300 CONTINUE
 741       CALL INTERP(WORK,GSNW,IMAX,JMAX,DP,IP)
 742 C
 743       DO 400 J=1,JMAX
 744         DO 410 I=1,IMAX
 745           GSNW(I,J)=GSNW(I,J)/100.0
 746   410   CONTINUE
 747   400 CONTINUE
 748 C   -----
 749       CALL MOVERD(GSNW, WRK, IMAX*JMAX)
 750       CALL WRTDAT
 751      1(NINFL0 , IDATE , -1    , 'SURF', 'SEW ',
 752      2 'SNOW EQUIVALENT WATER           ', 'M               ',
 753      3 0     , 0     , WRK   , IMAX  , JMAX  , I2    )
 754       WRITE(6,*) '## SNOW ANALYSIS WAS WRITTEN'
 755       ENDIF
 756 C   =================================================================
 757 C   >>>   EOF                                                     <<<
 758 C   =================================================================
 759       WRITE(6,*) '## PREGSM IS NORMAL ENDED'
 760 C
 761       END SUBROUTINE PREGSM