var/convertor/wave2grid_kma/PREGSM1.inc

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