C*********************************************************************** PROGRAM PREGSM USE module_wave2grid_kma ! Duplicated in module ! PARAMETER ( KMAX=30 ) ! PARAMETER ( IMAX=640, JMAX=320 ) ! PARAMETER ( IMAXE=640, JMAXE=321 ) ! PARAMETER ( ISST=360, JSST=181 ) ! PARAMETER ( ISNW=360, JSNW=180 ) ! PARAMETER ( IDIM=428, JDIM=214 ) ! MAX(MAX,SST,SNW) ! PARAMETER ( MAXJZ=16 ) ! PARAMETER (MEND1 =214,NEND1=214,JEND1=214) ! PARAMETER (JMAXHF= JMAX/2) ! PARAMETER (MNWAV =MEND1*(MEND1+1)/2) ! PARAMETER (IVAR=6,IMX=IMAX+2) C INTEGER IDATE(5), IDGES(5), IDSST(5) CHARACTER*8 FILE, MODEL, RESL CHARACTER*80 CINF(10) CHARACTER*4 TYPE, EXPR, KTUNIT, NPROD, NPROM, VCODD, VCODM CHARACTER*4 LEVEL, ELEM CHARACTER*32 TITLE CHARACTER*16 UNIT CHARACTER*8 MDLINF(4) REAL DTHPRO(7) INTEGER ITYP(2) CHARACTER*48 LABEL INTEGER JTINF(2) CHARACTER*10 FROMUNPACK INTEGER IUNPACK C DIMENSION A(KMAX+1), B(KMAX+1), AAM(KMAX+1), BBM(KMAX+1) DIMENSION AGD(KMAX+1), BGD(KMAX+1), AGM(KMAX+1), BGM(KMAX+1) DIMENSION GPHIS(IMAX*JMAX) REAL, DIMENSION(IMAX,JMAX) :: GAU REAL, DIMENSION(JMAX) :: SINCLT,COSCLT,GW,DGW,DCOSCL,COLRAD,DY COMMON PSE (IMAXE,JMAXE), 1 GZE (IMAXE,JMAXE,KMAX), GTE (IMAXE,JMAXE,KMAX), 2 GUE (IMAXE,JMAXE,KMAX), GVE (IMAXE,JMAXE,KMAX), 3 GQE (IMAXE,JMAXE,KMAX) COMMON PS (IMAX,JMAX), 1 GZ (IMAX,JMAX,KMAX), GT (IMAX,JMAX,KMAX), 2 GU (IMAX,JMAX,KMAX), GV (IMAX,JMAX,KMAX), 3 GQ (IMAX,JMAX,KMAX), AGT (IMAX,JMAX,KMAX), 4 GCWC(IMAX,JMAX,KMAX), GCVR(IMAX,JMAX,KMAX), 5 GUMB(IMAX,JMAX,KMAX), 6 GSST(IMAX,JMAX) , GSNW(IMAX,JMAX) DIMENSION VLG(IMAX,JMAX,KMAX) C DIMENSION WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX), REAL * 8 WRK1(IMAX,JMAX,KMAX), WRK2(IMAX,JMAX,KMAX) DIMENSION WRK3(IMAX,JMAX,KMAX), WRK4(IMAX,JMAX,KMAX), 2 WRK5(IMAX,JMAX,KMAX), WRK6(IMAX,JMAX,KMAX) CHARACTER*4 ALVL INTEGER*2 I2(IDIM*JDIM) REAL*8 WRK(IDIM,JDIM) DIMENSION SSTA(ISST*JSST), SEWA(ISNW,JSNW) DIMENSION COLRAD(JMAX), DY(JMAX), LY(JMAX) DIMENSION WORK(362,182),DP(4,IMAX,JMAX) INTEGER*2 IP(2,IMAX,JMAX) REAL*8 GAUL(JMAX),GAUW(JMAX),COCOT(JMAX) COMMON/CTETEN/TABLE(25000) COMMON/DTETEN/DTABLE(25000) REAL*8 TABLE,DTABLE,RGSA,G DIMENSION RLAT(MAXJZ), ZDAT(MAXJZ,KMAX) C NAMELIST /NAMFIL/ NALFL,NVPFL,NGSFL,NSSTFL,NSNWFL,NINFL, 1 KTLAG,IDCHCK,NDIGFL,NTPFL,NALOT,NRSFL NAMELIST /HEADIN/ TYPE,FILE,KTUNIT,IDTYPE, 1 IBACK,NNSP C------------------------------------------------------------------------ C NALFL : 3DOI INPUT FILE C NVPFL : VERTIAL LEVEL DEF. FILE C NTPFL : TOPO FILE C NALOT : 3DOI INPUT SAVE FILE C NRSFL : UNPACK INPUT FILE C------------------------------------------------------------------------ NAMELIST /NAMVER/ MODEL, RESL, EXPR, CINF C DATA RHMIN/1.0E-3/ DATA GRAV,ER,GASR,GAMMA/9.80665,6371.E3,287.04,0.0050/ DATA TLAPS,QCONS,QMIN,KST,ITERMX/2.0E-3,2.5E-6,1.0E-10,10,3/ C DATA NALFL ,NGSFL ,NSSTFL,NSNWFL,NINFL ,NVPFL ,NALOT,NRSFL 1 / 1, 2, -1, -1, 11, 21, 12, -1/ DATA KTLAG / 6/ DATA IDCHCK/ 1/ DATA A/0.00000000000D+00,0.00000000000D+00,0.00000000000D+00, & 0.00000000000D+00,1.546082500000000,5.614406590000000, & 12.42546270000000,21.63197330000000,32.59785460000000, & 44.61235050000000,57.01704410000000,69.26280210000000, & 80.92097470000000,91.66931150000001,101.2670900000000, & 109.5278170000000,116.2947540000000,121.4214780000000, & 124.7591550000000,126.1514430000000,125.4377290000000, & 122.4657440000000,117.1135710000000,109.3194430000000, & 99.11479190000000,86.65005490000000,72.19601440000000, & 56.09729000000000,38.66041560000000,19.99998470000000, & 0.00000000000D+00/ DATA B/1.0000000000000,0.9889042970000000,0.9682830569999999, & 0.9399999980000000,0.9042294030000000,0.8613848090000000, & 0.8124753240000000,0.7589231130000000,0.7022829060000000, & 0.6440208549999999,0.5853865740000000,0.5273658630000000, & 0.4706876280000000,0.4158638720000000,0.3632441160000000, & 0.3130739930000000,0.2655510310000000,0.2208738920000000, & 0.1792818900000000,0.1410827640000000,0.1066635850000000, & 7.647979300000D-02,5.101471400000D-02,3.070007300000D-02, & 1.579232499999D-02,6.205350000000D-03,1.324939000000D-03, & 0.000000000000D+00,0.000000000000D+00,0.000000000000D+00, & 0.000000000000D+00/ C C ================================================================= C >>> READ ANAL TIME <<< C ================================================================= READ(94,'(I4,3I2)') (IDATE(I),I=1,4) IDATE(5)=0 C ================================================================= C >>> NAMELIST (NAMFIL) <<< C ================================================================= READ(95,NAMFIL) READ(95,HEADIN) WRITE(6,NAMFIL) WRITE(6,HEADIN) C ================================================================= C >>> Select Input Source <<< C ================================================================= CALL GETENV('FROMUNPACK',FROMUNPACK) IF (LEN_TRIM(FROMUNPACK).EQ.0) THEN IUNPACK=0 ELSE READ(FROMUNPACK,'(I1)') IUNPACK END IF WRITE(6,*)'IUNPACK=',IUNPACK C ================================================================= C >>> GENERATE GAUSSIAN LATITUDES <<< C ================================================================= CALL GAUSS(GAUL,GAUW,JMAX) DO 800 J=1,JMAX COLRAD(J)=ACOS(GAUL(J)) 800 CONTINUE DO J=1,JMAXHF *vdir nodep GW ( J)=0.5*DGW (J) GW (JMAX+1-J)=0.5*DGW (J) COSCLT( J)= DCOSCL(J) COSCLT(JMAX+1-J)= -DCOSCL(J) SINCLT( J)=SQRT(1.0-DCOSCL(J)**2) SINCLT(JMAX+1-J)=SQRT(1.0-DCOSCL(J)**2) END DO CALL ZMNLAT( RLAT, MAXJZ, COLRAD, JMAX ) C C ================================================================= C >>> TETEN <<< C ================================================================= ICE = 1 CALL TETEN(ICE) C ================================================================= C >>> READ TOPO FILE C ================================================================= IF (NTPFL.GT.0) THEN READ(NTPFL)NWV,DUM,IGRD,JGRD IF ((IGRD.NE.IMAX).OR.(JGRD.NE.JMAX)) THEN WRITE(*,*)' TOPO DIM DOES NOT MATCH' WRITE(*,*)'IMAX=',IMAX,' IGRD=',IGRD WRITE(*,*)'JMAX=',JMAX,' JGRD=',JGRD STOP 9988 END IF READ(NTPFL) READ(NTPFL) READ(NTPFL)GPHIS WRITE(*,*)'GRID DISTANCE=',DUM END IF C--------------------------------------------------------------------- C READ INPUT DATA C--------------------------------------------------------------------- IF (NRSFL.LE.0) THEN CALL REDDAT_ASCII CLSW CALL REDDAT_BIN I(NALFL ,IMAXE ,JMAXE ,KMAX , PSE, O GTE ,GUE ,GVE ,GQE ) C--------------------------------------------------------------------- C +++ CONVERT LAT/LON to GAUSS C--------------------------------------------------------------------- CALL LT2GAU (PSE,IMAXE,JMAXE,IMAX,JMAX, 1 COLRAD,PS,DY,LY) DO K = 1, KMAX CALL LT2GAU (GTE(:,:,K),IMAXE,JMAXE,IMAX,JMAX, 1 COLRAD,GT(:,:,K),DY,LY) CALL LT2GAU (GUE(:,:,K),IMAXE,JMAXE,IMAX,JMAX, 1 COLRAD,GU(:,:,K),DY,LY) CALL LT2GAU (GVE(:,:,K),IMAXE,JMAXE,IMAX,JMAX, 1 COLRAD,GV(:,:,K),DY,LY) CALL LT2GAU (GQE(:,:,K),IMAXE,JMAXE,IMAX,JMAX, 1 COLRAD,GQ(:,:,K),DY,LY) ENDDO C ================================================================= C >>> PS, TEMP, Q -> Z C ================================================================= RGAS = 287.04 G = 9.80665 CALL GPLHGT I (PS,GT,GQ,GPHIS,IMAX,JMAX,KMAX,RGAS,G,A,B, I 1,JMAX, O GZ) CLSW do k=1,22,3 CLSW do j=1,jmax CLSW write(99,FMT='(10F12.5,1x)') (GZ(I,J,K),I=1,IMAX) CLSW enddo CLSW enddo C ================================================================== C >>> SAVE INPUT DATA C ================================================================== IF (NALOT.GT.0) THEN WRITE(NALOT)PS WRITE(NALOT)GZ WRITE(NALOT)GU WRITE(NALOT)GV WRITE(NALOT)GQ WRITE(NALOT)GT END IF ELSE ! START WITH UNPACK FILE LARHM=20 READ(NRSFL)IDATE READ(NRSFL)PS READ(NRSFL)GZ READ(NRSFL)GU READ(NRSFL)GV READ(NRSFL)GQ READ(NRSFL)AGT END IF ! READ ANAL FINISH CLSW write(99,*) ' Gauss GT' CLSW do k=1,2 CLSW do j=1,jmax CLSW write(99,FMT='(10F12.5,1x)') (GT(I,J,k),I=1,IMAX) CLSW enddo CLSW enddo C--------------------------------------------------------------------- C DO J = 1, JMAX C write(99,FMT='(10F12.5,1x)') (GAU(I,J),I=1,IMAX) C ENDDO 1000 CONTINUE C ================================================================= C >>> NAMELIST (NAMVER) <<< C ================================================================= CINF(1)=' ';CINF(2)=' ';CINF(3)=' ';CINF(4)=' ';CINF(5)=' ' CINF(6)=' ';CINF(7)=' ';CINF(8)=' ';CINF(9)=' ';CINF(10)=' ' READ(95,NAMVER) WRITE(6,NAMVER) C ================================================================= IF(NGSFL.GE.0) THEN CALL REDGES I(NGSFL ,IMAX ,JMAX ,KMAX ,KTLAG ,IDATE ,IDCHCK, O IDGES ,AGD ,BGD ,AGM ,BGM ,GCWC ,GCVR ,GUMB , W I2 ,IDSST ) ENDIF C ================================================================= C >>> Z -> TV <<< C ================================================================= C CALL CTIME( 4, 'ZE2TVE ' ) C >>> GT IS TV (OUTPUT) IF (NTPFL.LT.0) THEN CALL GH2TV(GZ, GT, PS, GPHIS, A, B, 1 IMAX , JMAX , KMAX ,WRK1 , WRK2 , WRK3 , WRK4) ELSE CALL ZE2TVE( GZ , GT , PS , A , B , I IMAX , JMAX , KMAX , W VLG , WRK1 , WRK2 , WRK3 , WRK4 , WRK5 , W WRK6 ) C CLSW write(99,*) ' Z->TV' CLSW do k=1,2 CLSW do j=1,jmax CLSW write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX) CLSW enddo CLSW enddo END IF CLSW CALL ZMNT( ZDAT, MAXJZ, KMAX, GT , IMAX, JMAX ) CLSW CALL OUTZ( ZDAT, MAXJZ, KMAX, 'TV ', CLSW 1 'TV ', 'K ', CLSW 2 0, RLAT, 'KMAX' ) C ================================================================= C >>> RH, TV -> Q, T <<< C ================================================================= IDX=1 CALL CRH2SHA I(IMAX*JMAX, KMAX, PS, A, B, GRAV,GASR,TLAPS,QCONS,QMIN,KST,ITERMX, I IDX, LARHM, O GQ, GT) write(99,*) ' after RH, TV -> Q, T' do k=1,2 do j=1,jmax write(99,FMT='(10F12.5,1x)') (GT(I,J,K),I=1,IMAX) enddo enddo C ***************************************************************** C >>> OUTPUT INITIAL VALUE <<< C ***************************************************************** C ================================================================= C >>> HEADER <<< C ================================================================= CALL WRTHED I(NINFL , I 'GVS1',IDATE ,'INITETA ',MODEL, RESL, I EXPR ,'HOUR',1 ,0 ,0 , I IMAX ,JMAX ,'GAUS',360.0/IMAX, REAL(JMAX), I 1.0 ,(JMAX+1)/2.0, 0.0 ,0.0 , I 'ETA ',KMAX ,A ,B , I IMAX ,JMAX ,'GAUS',360.0/IMAX, REAL(JMAX), I 1.0 ,(JMAX+1)/2.0, 0.0 ,0.0 , I 'ETA ',KMAX ,A ,B , I CINF ) C C ================================================================= C >>> PS <<< C ================================================================= CALL MOVERD(PS, WRK, IMAX*JMAX) CALL WRTDAT 1(NINFL , IDATE , -1 , 'SURF', 'P ', 2 'P ', 'HPA ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) C C ================================================================= C >>> U, V <<< C ================================================================= DO 9030 K=1,KMAX CALL MOVERD(GU(1,1,K), WRK, IMAX*JMAX) WRITE(ALVL(1:4), '(I4)') K CALL WRTDAT 1 (NINFL , IDATE , -1 , ALVL , 'U ', 2 'U ', 'M/S ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) 9030 CONTINUE DO 9040 K=1,KMAX CALL MOVERD(GV(1,1,K), WRK, IMAX*JMAX) WRITE(ALVL(1:4), '(I4)') K CALL WRTDAT 1 (NINFL , IDATE , -1 , ALVL , 'V ', 2 'V ', 'M/S ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) 9040 CONTINUE C ================================================================= C >>> T, Q <<< C ================================================================= DO 9010 K=1,KMAX CALL MOVERD(GT(1,1,K), WRK, IMAX*JMAX) WRITE(ALVL(1:4), '(I4)') K CALL WRTDAT 1 (NINFL , IDATE , -1 , ALVL , 'T ', 2 'T ', 'K ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) 9010 CONTINUE DO 9020 K=1,KMAX CALL MOVERD(GQ(1,1,K), WRK, IMAX*JMAX) WRITE(ALVL(1:4), '(I4)') K CALL WRTDAT 1 (NINFL , IDATE , -1 , ALVL , 'Q ', 2 'Q ', 'KG/KG ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) 9020 CONTINUE C ================================================================= C >>> SAVE INPUT FIELD FOR DIAG. C ================================================================= IF (NDIGFL.GT.0) THEN WRITE(NDIGFL)GT WRITE(NDIGFL)GQ END IF C C ================================================================= C >>> CWC, CVR <<< C ================================================================= IF(NGSFL.GT.0) THEN DO 9050 K=1,KMAX CALL MOVERD(GCWC(1,1,K), WRK, IMAX*JMAX) WRITE(ALVL(1:4), '(I4)') K CALL WRTDAT 1 (NINFL , IDATE , -1 , ALVL , 'CWC ', 2 'CLOUD WATER CONTENT ', 'KG/KG ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) 9050 CONTINUE DO 9060 K=1,KMAX CALL MOVERD(GCVR(1,1,K), WRK, IMAX*JMAX) WRITE(ALVL(1:4), '(I4)') K CALL WRTDAT 1 (NINFL , IDATE , -1 , ALVL , 'CVR ', 2 'CLOUD COVER ', '- ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) 9060 CONTINUE C C ================================================================= C >>> UMB <<< C ================================================================= DO 9070 K=1,KMAX CALL MOVERD(GUMB(1,1,K), WRK, IMAX*JMAX) WRITE(ALVL(1:4), '(I4)') K CALL WRTDAT 1 (NINFL , IDATE , -1 , ALVL , 'UMB ', 2 'UPWARD MASS FLUX AT CLOUD BASE ', 'KG/S/M**2 ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) 9070 CONTINUE END IF !NGSFL>0 C C ***************************************************************** C >>> SST ANOMALY <<< C ***************************************************************** IF( NSSTFL.NE.-1 ) THEN CALL GETTYP(NSSTFL,IOTYP) C IF(IOTYP.EQ.1) THEN C CALL GVDFIR(NSSTFL, C 1 IDSST,IBACK,IM,JM,MDLINF,DTHPRO,CINF,ITYP,IRTN) C WRITE(6,*) 'GVDFIR:IRTN=',IRTN C CALL GVDFNR(NSSTFL,IDSST,0,'SURF','SSTA', C 1 LABEL,JTINF,SSTA,IRTN) C WRITE(6,*) 'GVDFNR:IRTN=',IRTN WRITE(*,*)' UNKNOWN IOTYP:1' STOP 9999 ELSE IF(IOTYP.EQ.3) THEN C ================================================================= C >>> HEADER <<< C ================================================================= CALL REDHED I(NSSTFL, O TYPE ,IDSST ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE, O IBACK ,NNSP , O IMD ,JMD ,NPROD ,FLONID, FLATID, O XID ,XJD ,XLATD ,XLOND , O VCODD ,KMD ,A ,B , O IMM ,JMM ,NPROM ,FLONIM, FLATIM, O XIM ,XJM ,XLATM ,XLONM , O VCODM ,KMM ,AAM ,BBM , O CINF ) C ================================================================= C >>> SST ANOMALLY <<< C ================================================================= DO 1 I=1,NNSP READ(NSSTFL) 1 CONTINUE 3001 CALL REDDAT I(NSSTFL, O IDSST , KT , O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA , O SSTA , IRTN , I ISST , JSST , 1 , W BASE , AMP ,I2 ) IF(ELEM.NE.'SSTA') GOTO 3001 WRITE(6,*) '## ', TITLE, '(',UNIT,')' ENDIF C WRITE(6,*) '## ', IDSST, KT IF( IDCHCK.EQ.1 ) THEN CALL CVDATE( IDGES, IDSST, 24 ) IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR. 1 IDATE(3).NE.IDGES(3) ) THEN WRITE(6,*) 'SSTA : DATE CHECK ERROR' STOP 999 ENDIF ENDIF C CALL LT2GAU(SSTA,ISST,JSST,IMAX,JMAX,COLRAD,GSST,DY,LY) CALL MOVERD(GSST, WRK, IMAX*JMAX) CALL WRTDAT 1(NINFL , IDATE , -1 , 'SURF', 'SSTA', 2 'SST ANOMALLY ', 'K ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) WRITE(6,*) '## SST ANOMALLY WAS WRITTEN' C ENDIF C C ***************************************************************** C >>> SNOW ANALYSIS <<< C ***************************************************************** IF( NSNWFL.NE.-1 ) THEN C ================================================================= C >>> HEADER <<< C ================================================================= CALL REDHED I(NSNWFL, O TYPE ,IDSST ,FILE ,MODEL ,RESL ,EXPR ,KTUNIT,IDTYPE, O IBACK ,NNSP , O IMD ,JMD ,NPROD ,FLONID, FLATID, O XID ,XJD ,XLATD ,XLOND , O VCODD ,KMD ,A ,B , O IMM ,JMM ,NPROM ,FLONIM, FLATIM, O XIM ,XJM ,XLATM ,XLONM , O VCODM ,KMM ,AAM ,BBM , O CINF ) DO 2 I=1,NNSP READ(NSNWFL) 2 CONTINUE C ================================================================= C >>> SNOW ANALYSIS <<< C ================================================================= CALL REDDAT I(NSNWFL, O IDSST , KT , O LEVEL , ELEM , TITLE , UNIT , KTSD , KTSA , O SEWA , IRTN , I ISNW , JSNW , 1 , W BASE , AMP ,I2 ) WRITE(6,*) '## ', TITLE, '(',UNIT,')' WRITE(6,*) '## ', IDSST, KT IF( IDCHCK.EQ.1 ) THEN CALL CVDATE( IDGES, IDSST, 24 ) IF( IDATE(1).NE.IDGES(1).OR.IDATE(2).NE.IDGES(2).OR. 1 IDATE(3).NE.IDGES(3) ) THEN WRITE(6,*) 'SNOW : DATE CHECK ERROR' STOP 999 ENDIF ENDIF C ----- CALL SETWHT (IMAX,JMAX,DP,IP,GAUL,GAUW,COCOT) DO 100 J=1,180 DO 100 I=1,360 WORK(I+1,J+1)=SEWA(I,J) 100 CONTINUE DO 200 J=1,180 WORK( 1,J+1)=WORK(361,J+1) WORK(362,J+1)=WORK( 2,J+1) 200 CONTINUE DO 300 I=1,362 WORK(I, 1)=WORK(I, 2) WORK(I,182)=WORK(I,181) 300 CONTINUE CALL INTERP(WORK,GSNW,IMAX,JMAX,DP,IP) C DO 400 J=1,JMAX DO 410 I=1,IMAX GSNW(I,J)=GSNW(I,J)/100.0 410 CONTINUE 400 CONTINUE C ----- CALL MOVERD(GSNW, WRK, IMAX*JMAX) CALL WRTDAT 1(NINFL , IDATE , -1 , 'SURF', 'SEW ', 2 'SNOW EQUIVALENT WATER ', 'M ', 3 0 , 0 , WRK , IMAX , JMAX , I2 ) WRITE(6,*) '## SNOW ANALYSIS WAS WRITTEN' ENDIF C ================================================================= C >>> EOF <<< C ================================================================= WRITE(6,*) '## PREGSM IS NORMAL ENDED' C STOP END