SUBROUTINE ALBAER(MON,SLMSK,SNOWF,ZORLF,COSZF,TSEAF,HPRIF,JSNO, C1197 SUBROUTINE ALBAER(MON,SLMSK,SNOWF,ZORLF,COSZF,TSEAF, 1 ALVSF,ALNSF,ALVWF,ALNWF,FACSF,FACWF,PAERF, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,SLMSKR, 3 ALVBR,ALNBR,ALVDR,ALNDR,PAERR) CFPP$ NOCONCUR R C******************************************************************* C THIS PROGRAM COMPUTES FOUR COMPONENTS OF SURFACE ALBEDOS (I.E. C VIS-NIR, DIRECT-DIFFUSED) BASED ON BRIEGLEB'S SCHEME. AND C BILINEARLY INTERPOLATES ALBEDO AND AEROSOL DISTRIBUTION TO C RADIATION GRID. C C INPUT VARIABLES: C MON - MONTH OF THE YEAR C SLMSK - SEA(0),LAND(1),ICE(2) MASK ON FCST MODEL GRID C SNOWF - SNOW DEPTH WATER EQUIVALENT IN MM C ZORLF - SURFACE ROUGHNESS IN CM C COSZF - COSIN OF SOLAR ZENITH ANGLE C TSEAF - SEA SURFACE TEMPERATURE IN K C1197 HPRIF - TOPOGRAPHIC SDV IN M C1197 JSNO - LAT AT 70 DEG - INDICATING EXTENT OF PERM SNOW COVER C ALVSF - MEAN VIS ALBEDO WITH STRONG COSZ DEPENDENCY C ALNSF - MEAN NIR ALBEDO WITH STRONG COSZ DEPENDENCY C ALVWF - MEAN VIS ALBEDO WITH WEAK COSZ DEPENDENCY C ALNWF - MEAN NIR ALBEDO WITH WEAK COSZ DEPENDENCY C PAERF - AEROSOL DISTRIBUTION FACTOR ON FCST GRID C SLMSKR - SEA(0),LAND(1),ICE(2) MASK ON RADIATION GRID C C OUTPUT VARIABLES: (ALL ON RADIATION GRID) C ALVBR - VIS BEAM SURFACE ALBEDO C ALNBR - NIR BEAM SURFACE ALBEDO C ALVDR - VIS DIFF SURFACE ALBEDO C ALNDR - NIR DIFF SURFACE ALBEDO C PAERR - AEROSOL DISTRIBUTION FACTOR C****************************************************************** PARAMETER (IFCS= 384 , JFCS= 47 , IRAD= 384 , JRAD= 47 ) C --- INPUT D I M E N S I O N 1 SLMSK( 384 , 47 ),SNOWF( 384 , 47 ),ZORLF( 384 , 47 ) C11972, TSEAF( 384 , 47 ),COSZF( 384 , 47 ) 2, TSEAF( 384 , 47 ),COSZF( 384 , 47 ),HPRIF( 384 , 47 ) 3, ALVSF( 384 , 47 ,4), ALNSF( 384 , 47 ,4) 4, ALVWF( 384 , 47 ,4), ALNWF( 384 , 47 ,4) 5, FACSF( 384 , 47 ), FACWF( 384 , 47 ) 6, PAERF( 384 , 47 ,5) 7, SLMSKR( 384 , 47 ), ILEFTR( 384 ), IRGHTR( 384 ) 8, WGRLON( 384 ), INRLAT( 47 ), WGRLAT( 47 ) C --- OUTPUT D I M E N S I O N 1 ALVBR( 384 , 47 ),ALNBR( 384 , 47 ),ALVDR( 384 , 47 ) 2, ALNDR( 384 , 47 ),PAERR( 384 ,5, 47 ) C --- INTERNAL VARIABLES D I M E N S I O N 1 ALVBF( 384 , 47 ),ALNBF( 384 , 47 ),WORK1( 384 ) 2, ALVDF( 384 , 47 ),ALNDF( 384 , 47 ),WORK2( 384 , 47 ) 3, ASNVB( 384 ), ASNNB( 384 ), ASNVD( 384 ), ASNND( 384 ) 4, ASEVB( 384 ), ASENB( 384 ), ASEVD( 384 ), ASEND( 384 ) 5, FSNO ( 384 ), FSEA ( 384 ), RFCS ( 384 ), RFCW ( 384 ) 6, FLND ( 384 ), MM(4) C DATA MM /4, 7, 10, 13/ C IF (MON.LT.1 .OR. MON.GT.12) THEN WRITE(6,4) MON 4 FORMAT(3X,'ERROR IN MONTH SPECIFICATION - MON=',I4) STOP 4 END IF K=1 10 IF (MON .LT. MM(K)) GO TO 12 K = K + 1 GO TO 10 12 K1 = K K2 = K + 1 IF (K2 .GT. 4) K2 = 1 F12 = FLOAT(MON - MM(K1) + 3) / 3.0 E 0 C DO 100 J=1,JFCS C DO 20 I=1,IFCS C --- MODIFIED SNOW ALBEDO SCHEME - UNITS CONVERT TO M C (ORIGINALLY SNOWF IN MM; ZORLF IN CM) ASNOW = 0.02*SNOWF(I,J) ARGH = MIN(1.0, MAX(.025, 0.01*ZORLF(I,J))) FSNO0 = ASNOW / (ARGH + ASNOW) IF (SLMSK(I,J).EQ.0.0 .AND. TSEAF(I,J).GT.271.2) 1 FSNO0 = 0.0 FSNO1 = 1.0 - FSNO0 FLND0 = FACSF(I,J) + FACWF(I,J) FSEA0 = MAX(0.0, 1.0 - FLND0) FSNO (I) = FSNO0 FSEA (I) = FSEA0 * FSNO1 FLND (I) = FLND0 * FSNO1 C --- DIFFUSED SEA SURFACE ALBEDO IF (SLMSK(I,J).EQ.2.0 .OR. TSEAF(I,J) .LT. 271.2) THEN ASEVD(I) = 0.70 ASEND(I) = 0.65 ELSE ASEVD(I) = 0.06 ASEND(I) = 0.06 END IF C --- DIFFUSED SNOW ALBEDO C IF (SLMSK(I,J).EQ.1.0 .AND. J.GT.JSNO) THEN C IF (SLMSK(I,J).EQ.1.0 .AND. TSEAF(I,J).GT.250.) THEN IF (SLMSK(I,J).EQ.1.0 .AND. 1 (J.GT.JSNO.OR.TSEAF(I,J).GT.271.2)) THEN C1197 HFAC = MAX(0.15, MIN(1.0, 1.2125-1.0625E-3*HPRIF(I,J))) HFAC = MAX(0.10, MIN(1.0, 1.225-1.125E-3*HPRIF(I,J))) ELSE HFAC = MAX(0.75, MIN(1.0, 1.0625-0.3125E-3*HPRIF(I,J))) END IF ASNVD(I) = 0.90 * HFAC ASNND(I) = 0.75 * HFAC 20 CONTINUE C DO 40 I=1,IFCS C --- DIRECT SNOW ALBEDO IF (COSZF(I,J) .LT. 0.5) THEN CSNOW = 0.5 * (3.0 / (1.0+4.0*COSZF(I,J)) - 1.0) ASNVB(I) = MIN( 0.98, ASNVD(I)+(1.0-ASNVD(I))*CSNOW ) ASNNB(I) = MIN( 0.98, ASNND(I)+(1.0-ASNND(I))*CSNOW ) ELSE ASNVB(I) = ASNVD(I) ASNNB(I) = ASNND(I) END IF C --- DIRECT SEA SURFACE ALBEDO IF (COSZF(I,J) .GT.0.0) THEN RFCS(I) = 1.4 / (1.0 + 0.4*COSZF(I,J)) RFCW(I) = 1.1 / (1.0 + 0.2*COSZF(I,J)) IF (TSEAF(I,J) .GE. 2.7315E+2 ) THEN ASEVB(I) = MAX(0.055, 0.026/(COSZF(I,J)**1.7+0.065) 1 + 0.15 * (COSZF(I,J)-0.1) * (COSZF(I,J)-0.5) 2 * (COSZF(I,J)-1.0)) ASENB(I) = ASEVB(I) ELSE ASEVB(I) = ASEVD(I) ASENB(I) = ASEND(I) END IF ELSE RFCS(I) = 1.0 RFCW(I) = 1.0 ASEVB(I) = ASEVD(I) ASENB(I) = ASEND(I) END IF 40 CONTINUE DO 60 I=1,IFCS A1 = (ALVSF(I,J,K1) + (ALVSF(I,J,K2)-ALVSF(I,J,K1))*F12) 1 * FACSF(I,J) B1 = (ALVWF(I,J,K1) + (ALVWF(I,J,K2)-ALVWF(I,J,K1))*F12) 1 * FACWF(I,J) A2 = (ALNSF(I,J,K1) + (ALNSF(I,J,K2)-ALNSF(I,J,K1))*F12) 1 * FACSF(I,J) B2 = (ALNWF(I,J,K1) + (ALNWF(I,J,K2)-ALNWF(I,J,K1))*F12) 1 * FACWF(I,J) ALVBF(I,J) = (A1*RFCS(I) + B1*RFCW(I))*FLND(I) 1 + ASEVB(I)*FSEA(I) + ASNVB(I)*FSNO(I) ALVDF(I,J) = (A1 + B1 )*FLND(I) 1 + ASEVD(I)*FSEA(I) + ASNVD(I)*FSNO(I) ALNBF(I,J) = (A2*RFCS(I) + B2*RFCW(I))*FLND(I) 1 + ASENB(I)*FSEA(I) + ASNNB(I)*FSNO(I) ALNDF(I,J) = (A2 + B2 )*FLND(I) 1 + ASEND(I)*FSEA(I) + ASNND(I)*FSNO(I) 60 CONTINUE C 100 CONTINUE C C.... INTERPOLATE ALBEDO TO RADIATION GRID CALL GGINTF(ALVBF,IFCS,JFCS,JFCS, 1 ALVBR,IRAD,JRAD,JRAD,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK1,1,1,1) CALL GGINTF(ALVDF,IFCS,JFCS,JFCS, 1 ALVDR,IRAD,JRAD,JRAD,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK1,1,1,1) CALL GGINTF(ALNBF,IFCS,JFCS,JFCS, 1 ALNBR,IRAD,JRAD,JRAD,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK1,1,1,1) CALL GGINTF(ALNDF,IFCS,JFCS,JFCS, 1 ALNDR,IRAD,JRAD,JRAD,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK1,1,1,1) C.... AEROSOL DISTRIBUTIONS c do i=1,384*47,384 c if (alvbf(i,1) .lt. 0.0) then c print *,' alvbf=',alvbf(i,1),' alvdf=',alvdf(i,1) c *,' alnbf=',alnbf(i,1),' alndf=',alndf(i,1) c endif c enddo c do i=1,256*31,256 c if (alvbr(i,1) .lt. 0.0) then c print *,' alvbr=',alvbr(i,1),' alvdr=',alvdr(i,1) c *,' alnbr=',alnbr(i,1),' alndr=',alndr(i,1) c endif c enddo DO 150 K=1,5 CALL GGINTF(PAERF(1,1,K),IFCS,JFCS,JFCS, 1 WORK2,IRAD,JRAD,JRAD,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK1,1,1,1) DO 120 J=1,JRAD DO 120 I=1,IRAD IF (WORK2(I,J) .LT. 0.01) WORK2(I,J) = 0.0 PAERR(I,K,J) = MIN(1.0, WORK2(I,J)) 120 CONTINUE 150 CONTINUE C.... FINAL CHECK TO MAKE TOTAL IS ONE DO 200 J=1,JRAD DO 200 I=1,IRAD IF (SLMSKR(I,J).EQ.0.0 .OR. SLMSKR(I,J).EQ.2.0) THEN PSEA = PAERR(I,3,J) + PAERR(I,5,J) PAERR(I,1,J) = 0.0 PAERR(I,2,J) = 0.0 PAERR(I,4,J) = 0.0 IF (PSEA .GT. 1.0) THEN PAERR(I,3,J) = MIN(1.0, PAERR(I,3,J)) PAERR(I,5,J) = 1.0 - PAERR(I,3,J) ELSE IF (PSEA .LT. 1.0) THEN PAERR(I,3,J) = 1.0 - PAERR(I,5,J) END IF ELSE PLND = PAERR(I,1,J) + PAERR(I,2,J) + PAERR(I,4,J) PAERR(I,5,J) = 0.0 IF (PLND .GT. 1.0) THEN PAERR(I,3,J) = 0.0 PAERR(I,2,J) = MIN(1.0, PAERR(I,2,J)) IF (PAERR(I,1,J) .GT. 0.0) THEN PAERR(I,4,J) = 0.0 PAERR(I,1,J) = 1.0 - PAERR(I,2,J) ELSE PAERR(I,1,J) = 0.0 PAERR(I,4,J) = 1.0 - PAERR(I,2,J) END IF ELSE IF (PLND .LT. 1.0) THEN C --- USE MAR-I AS THE BACKGROUND FILL PAERR(I,3,J) = 1.0 - PLND END IF END IF 200 CONTINUE C RETURN END CFPP$ NOCONCUR R C-CRA SUBROUTINE CNVCLD(CLSTP,IM,RN,KBOT,KTOP,CV,CVB,CVT) SUBROUTINE CNVCLD(CLSTP,IMX2,RN,KBOT,KTOP,CV,CVB,CVT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CNVCLD COMPUTES CONVECTIVE CLOUD COVER C PRGMMR: IREDELL ORG: W/NMC23 DATE: 91-05-07 C C ABSTRACT: COMPUTES CONVECTIVE CLOUD COVER AND CLOUD TOPS AND BOTTOMS C AFTER THE DEEP CONVECTION IS INVOKED. CLOUD COVER IS INTERPOLATED C FROM A TABLE RELATING CLOUD COVER TO PRECIPITATION RATE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL C C USAGE: CALL CNVCLD(CMEAN,LAT,IISTP,DT,RN,KBOT,KTOP,CV,CVB,CVT) C C INPUT ARGUMENT LIST: C CMEAN - REAL FLAG (GE 0 TO ACCUMULATE, EQ 99 TO RETURN VALUES) C LAT - INTEGER LATITUDE INDEX C IISTP - INTEGER TIME STEP NUMBER C DT - REAL TIME STEP IN SECONDS C RN - REAL (NX) CONVECTIVE RAIN IN METERS C KBOT - INTEGER (NX) CLOUD BOTTOM LEVEL C KTOP - INTEGER (NX) CLOUD TOP LEVEL C C OUTPUT ARGUMENT LIST: C CV - REAL (NX,NY) CONVECTIVE CLOUD COVER C CVB - REAL (NX,NY) CONVECTIVE CLOUD BASE LEVEL C CVT - REAL (NX,NY) CONVECTIVE CLOUD TOP LEVEL C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ DIMENSION RN(IMX2),KBOT(IMX2),KTOP(IMX2), 1 CV(IMX2),CVB(IMX2),CVT(IMX2) C-CRA DIMENSION RN(IM),KBOT(IM),KTOP(IM), C-CRA1 CV(IM),CVB(IM),CVT(IM) C LOCAL WORK VARIABLES AND ARRAYS C-CRA DIMENSION NMD(IM),PMD(IM) DIMENSION NMD( 384 ),PMD( 384 ) C LOCAL SAVE VARIABLES AND ARRAYS PARAMETER(NCC=9) DIMENSION CC(NCC),P(NCC) DATA CC/0.,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8/ DATA P/.14,.31,.70,1.6,3.4,7.7,17.,38.,85./ DATA CVB0/100./ C IM=IMX2 C----------------------------------------------------------------------- C INITIALIZE CONVECTIVE RAIN AND RANGE IF(CLSTP.LE.0..AND.CLSTP.GT.-10.) THEN DO I=1,IM CV(I)=0. CVB(I)=CVB0 CVT(I)=0. C CVB(I)=0. C CVT(I)=0. ENDDO ENDIF C----------------------------------------------------------------------- C ACCUMULATE CONVECTIVE RAIN AND RANGE IF(CLSTP.GT.-99.) THEN DO I=1,IM IF(RN(I).GT.0.) THEN CV(I)=CV(I)+RN(I) CVB(I)=MIN(CVB(I),FLOAT(KBOT(I))) CVT(I)=MAX(CVT(I),FLOAT(KTOP(I))) C CVT(I)=MAX(CVT(I),FLOAT(KTOP(I)+1)) C CVB(I)=CVB(I)+KBOT(I)*RN(I) C CVT(I)=CVT(I)+(KTOP(I))*RN(I) C CVT(I)=CVT(I)+(KTOP(I)+1)*RN(I) ENDIF ENDDO ENDIF C----------------------------------------------------------------------- C CONVERT PRECIPITATION RATE INTO CLOUD FRACTION IF (CLSTP.GT.0..OR.(CLSTP.LT.0.AND.CLSTP.GT.-10.)) THEN DO I=1,IM IF(CV(I).GT.0.) THEN C CVB(I)=NINT(CVB(I)/CV(I)) C CVT(I)=NINT(CVT(I)/CV(I)) ELSE CVB(I)=CVB0 CVT(I)=0. ENDIF PMD(I)=CV(I)*(24.E+3/ABS(CLSTP)) NMD(I)=0 ENDDO DO N=1,NCC DO I=1,IM IF(PMD(I).GT.P(N)) NMD(I)=N ENDDO ENDDO DO I=1,IM IF(NMD(I).EQ.0) THEN CV(I)=0. CVB(I)=CVB0 CVT(I)=0. ELSEIF(NMD(I).EQ.NCC) THEN CV(I)=CC(NCC) ELSE CC1=CC(NMD(I)) CC2=CC(NMD(I)+1) P1=P(NMD(I)) P2=P(NMD(I)+1) CV(I)=CC1+(CC2-CC1)*(PMD(I)-P1)/(P2-P1) ENDIF ENDDO ENDIF C----------------------------------------------------------------------- RETURN END SUBROUTINE DAMPUX(DIV,VOR,TEM,RMX,DELTIM,FDAMP,ARN,SPDMAX) DIMENSION FDAMP( 4032 ),ARN( 4032 ),SPDMAX( 28 ), 1 RMX( 4033 , 28 ), 3 VOR( 4033 , 28 ), DIV( 4033 , 28 ),TEM( 4033 , 28 ) COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C................................................................. DO 410 J=1, 4032 ARN(J)=SNNP1(J)+0.25 E 0 ARN(J)= SQRT(ARN(J)) ARN(J)=ARN(J)-0.5 E 0 410 CONTINUE ALFA=2.5 E 0 BETA= 6.3712E+6 *1.009 E 0/DELTIM ALFADT=ALFA*DELTIM/ 6.3712E+6 C................................................. DO 80 K=1, 28 RNCRIT=BETA/SPDMAX(K) COEF=ALFADT*SPDMAX(K) DO 420 J=1, 4032 IF (ARN(J).GT.RNCRIT) THEN DIV(J,K) =DIV(J,K)/(1.+(ARN(J)-RNCRIT)*COEF) VOR(J,K) =VOR(J,K)/(1.+(ARN(J)-RNCRIT)*COEF) TEM(J,K) =TEM(J,K)/(1.+(ARN(J)-RNCRIT)*COEF) END IF 420 CONTINUE DO 422 IT=1, 1 IS=(IT-1)* 28 L=IS+K DO 421 J=1, 4032 IF (ARN(J).GT.RNCRIT) THEN RMX(J,L) =RMX(J,L)/(1.+(ARN(J)-RNCRIT)*COEF) END IF 421 CONTINUE 422 CONTINUE 80 CONTINUE RETURN END CFPP$ NOCONCUR R SUBROUTINE DCYC2(IMX2,KMX,SOLHR,SLAG,SINLAB,COSLAB,SDEC,CDEC, & XLON,CZMN,SFCDLW,SFCNSW,TF,TSEA,TSFLW,SWH,HLW, & DLWSFC,ULWSFC,SLRAD,TAU) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DCYC2 ALTERS RADIATION FOR APPROX DIURNAL CYCLE C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-05-06 C KENNETH CAMPANA C C ABSTRACT: A DIURNAL CYCLE APPROXIMATION IS APPLIED TO PREVIOUSLY C COMPUTED RADIATIVE FLUXES AND HEATING RATES. FIRST,THE CURRENT C LOCAL-TIME VALUE (FOR THIS PARTICULAR MODEL TIME STEP) OF THE C COSINE SOLAR ZENITH ANGLE (COSZ) IS COMPUTED FOR ALL GAUSSIAN GRID C POINTS. SHORTWAVE (SW) HEATING RATES WHICH WERE COMPUTED WITH C LATITUDINAL MEAN COSZ IN THE SEPARATE RADIATION CALCULATION C ARE WEIGHTED BY THE RATIO OF ACTUAL TO MEAN COSZ (SEE MRF MODEL C DOCUMENTATION,1988,CHAPTER 3,'RADIATIVE PROCESSES',AUTHORED BY C K. CAMPANA,..). SURFACE SW FLUXES ARE ALSO COSZ WEIGHTED. SURFACE C LONGWAVE (LW) FLUX FROM THE ATMOSPHERE IS ALTERED EACH TIMESTEP C TO ACCOUNT FOR DIURNAL CHANGES OF MODEL TEMPERATURE IN THE LOWER C ATMOSPHERE. LW HEATING RATES FROM THE SEPARATE RADIATION C COMPUTATION ARE UNTOUCHED. C C PROGRAM HISTORY LOG: C 88-05-06 JOSEPH SELA C C USAGE: CALL DCYC2(LAT,SSDEC,SOLHR,COLRAD,CZMN,SFCDLW,SFCNSW, C TF,TOV,SLRAD,SWH,HLW,TAU) C INPUT ARGUMENT LIST: C LAT - ROW NUMBER OF GAUSSIAN LATITUDE(N.H.). C SSDEC - SINE OF THE SOLAR DECLINATION FOR TODAY'S DATE- C PART OF THE OUTPUT FROM RADIATION CODES. C SOLHR - TIME IN HOURS AFTER 00 HR GREENWICH. C COLRAD - CO-LATITUDES OF GAUSSIAN GRID IN RADIANS(N.H.). C CZMN - MEAN COSINE SOLAR ZENITH ANGLE FOR ALL GAUSSIAN LATS- C PART OF THE OUTPUT FROM RADIATION CODES. C SFCDLW - DOWNWARD LW FLUX AT EARTH SFC(FROM RADIATION CODE) C IN CAL CM-2 MIN-1. C SFCNSW - NET SW FLUX AT EARTH SFC(FROM RADIATION CODE USING C CZMN) IN CAL CM-2 MIN-1. C TF - CURRENT VALUE OF MODEL TEMPERATURES(W/O BASIC STATE) C IN DEG K. C TOV - BASIC STATE TEMPERATURE FOR ALL MODEL LAYERS(DEG K). C SWH - MODEL LYR SW HEATING RATES(FROM RADIATION CODE,USING C CZMN) - DEG/SEC. C HLW - MODEL LYR LW HEATING RATES(FROM RADIATION CODE), C IN DEG/SEC. C C OUTPUT ARGUMENT LIST: C SLRAD - SURFACE NET RADIATIVE FLUX (EXCEPT LW UPWARD FLUX C FROM SFC,WHICH IS ADDED IN PROGTN) - C UNITS ARE CAL CM-2 MIN-1 . C TAU - LAYER VALUES OF TEMPERATURE TENDENCY AFTER ADDING C ALTERED RADIATIVE HEATING RATES-UNITS ARE DEG/SEC. C C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ PARAMETER (HSIGMA= 5.6730E-8 ,CNWATT=- 4.1855E+0 *1.E4/60.) DIMENSION XLON(IMX2),CZMN(IMX2),SFCDLW(IMX2),SFCNSW(IMX2), & TF(IMX2),TSEA(IMX2),TSFLW(IMX2),SINLAB(IMX2), & SWH(IMX2,KMX),HLW(IMX2,KMX),COSLAB(IMX2), & DLWSFC(IMX2),ULWSFC(IMX2),SLRAD(IMX2),TAU(IMX2,KMX) C LOCAL DIMENSION DIMENSION XMU( 384 ) C HMHJ LON2=IMX2 LEVS=KMX C----------------------------------------------------------------------- C COMPUTE COSINE OF SOLAR ZENITH ANGLE FOR BOTH HEMISPHERES. CNS= 3.141593E+0 *(SOLHR-12.)/12.+SLAG DO I=1,LON2 SS=SINLAB(I)*SDEC CC=COSLAB(I)*CDEC CH=CC*COS(XLON(I)+CNS) XMU(I)=CH+SS C XMU(I)=(SINLAB(I)*SDEC) C 1 +(COSLAB(I)*CDEC)*COS(XLON(I)+CNS) ENDDO DO I=1,LON2 C NORMALIZE BY AVERAGE VALUE OVER RADIATION PERIOD FOR DAYTIME. IF(XMU(I).GT.0.01.AND.CZMN(I).GT.0.01) THEN XMU(I)=XMU(I)/CZMN(I) ELSE XMU(I)=0. ENDIF C ADJUST LONGWAVE FLUX AT SURFACE TO ACCOUNT FOR T CHANGES IN LAYER 1. SDLW=SFCDLW(I)*(TF(I)/TSFLW(I))**4 C RETURN NET SURFACE RADIATIVE FLUX. SLRAD(I)=SFCNSW(I)*XMU(I)+SDLW C RETURN DOWNWARD AND UPWARD LONGWAVE FLUX AT GROUND, RESPECTIVELY. DLWSFC(I)=SDLW*CNWATT ULWSFC(I)=HSIGMA*TSEA(I)**4 ENDDO C ADD RADIATIVE HEATING TO TEMPERATURE TENDENCY DO K=1,LEVS DO I=1,LON2 TAU(I,K)=TAU(I,K)+SWH(I,K)*XMU(I)+HLW(I,K) ENDDO ENDDO RETURN END SUBROUTINE DELDFSP(Q,QLAP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DELDFSP COMPUTE MODIFIED LAPLACIAN IN SPECTRAL SPAC C PRGMMR: KANAMITSU ORG: W/NP51 DATE: 97-03-10 C C ABSTRACT: COMPUTES THE MODIFIED HORIZONTAL LAPLACIAN IN SPECTRAL SPACE C FOR HORIZONTAL DIFFUSION CALCULATION OF TEMP AND HUM ON C GRID SPACE. C IF N IS THE TOTAL WAVENUMBER, MODIFIED LAPLACIAN IS EXPRESSE C -(N-N0)*(N-N0+1)/A**2*SPC(N,M), N-N0>0 C WHERE N0=0.55*JCAP C C PROGRAM HISTORY LOG: C 97-03-10 MASAO KANAMITSU C C USAGE: CALL DELDFSP(Q,RQ) C C INPUT ARGUMENT LIST: C Q - REAL ( 4033 ) LN(PS) SPECTRAL COEFFS C C OUTPUT ARGUMENT LIST: C QLAP - REAL ( 4033 ) QUSI-LAPLACIAN OF LN(PS) SPECTRAL COEFFS C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C C$$$ REAL Q( 4033 ) REAL QLAP( 4033 ) C PARAMETER(DIFCOF=3.E15,LEFRES=80,JDEL=2) C NP= 62 N0=0.55* 62 RTNP=DIFCOF/( 6.3712E+6 **4)*FLOAT(LEFRES*(LEFRES+1))**2 JDELH=JDEL/2 NPD=MAX(NP-N0,0) DN1=2.*RTNP/FLOAT(NPD*(NPD+1))**JDELH C I=0 DO NM=0, 62 DO MM=0, 62 -NM ND=MAX(NM+MM-N0,0) DN=DN1*FLOAT(ND*(ND+1))**JDELH QLAP(I+1)=Q(I+1)*DN QLAP(I+2)=Q(I+2)*DN I=I+2 ENDDO ENDDO C RETURN END SUBROUTINE DELDIF(RT,W,DELTIM,QM,SL,X,Y) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DELDIF HORIZONTAL DIFFUSION. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-03-15 C C ABSTRACT: HORIZONTAL DIFFUSION OF TEMPERATURE, MOISTURE, C VORTICITY AND DIVERGENCE. THE IMPLICIT LINEAR EQUATION C IS SOLVED USING THE LAPSE RATES OF GLOBALLY AVERAGED C TEMPERATURE AND MOISTURE TO TRANSFORM THE LAPLACIAN C FROM CONSTANT PRESSURE TO CONSTANT SIGMA SURFACES. C FOR THE T126 OPERATIONAL MODEL, DELDIF INVOKES C SECOND ORDER LEITH DIFFUSION ONLY ABOVE WAVENUMBER 69 C WITH A TIME SCALE OF 13080 SECONDS AT WAVENUMBER 126. C C PROGRAM HISTORY LOG: C 91-03-15 MARK IREDELL C C USAGE: CALL DELDIF (RT,W,DELTIM,QM,SL,X,Y) C INPUT ARGUMENT LIST: C RT - SPECIFIC HUMIDITY C W - VORTICITY C DELTIM - TIMESTEP C QM - LN(PSFC) C SL - SIGMA LAYER VALUES C X - DIVERGENCE C Y - TEMPERATURE C C OUTPUT ARGUMENT LIST: C RT - SPECIFIC HUMIDITY C W - VORTICITY C X - DIVERGENCE C Y - TEMPERATURE C C REMARKS: LOCAL VARIABLES THAT CAN BE MODIFIED TO CHANGE DIFFUSION ARE: C RTNP- RECIPROCAL OF TIME SCALE OF DIFFUSION AT WAVENUMBER NP C NP - WAVENUMBER AT WHICH RTNP DIFFUSION IS APPLIED C N0 - MAXIMUM WAVENUMBER FOR ZERO DIFFUSION C JDEL- ORDER OF DIFFUSION C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ DIMENSION SL( 28 ),QM( 4033 ) DIMENSION W( 4033 , 28 ),X( 4033 , 28 ), & Y( 4033 , 28 ),RT( 4033 , 28 ) DIMENSION DN( 4032 ) DATA IFIRST/0/ SAVE IFIRST,DN C PARAMETER(DIFCOF=3.E15,LEFRES=80,JDEL=2) C C IF(IFIRST.EQ.0) THEN IFIRST=1 C C RECIPROCAL OF TIME SCALE OF DIFFUSION AT REFERENCE WAVENUMBER NP C RTNP=DIFCOF/( 6.3712E+6 **4)*FLOAT(LEFRES*(LEFRES+1))**2 NP= 62 C C MAXIMUM WAVENUMBER FOR ZERO DIFFUSION C N0=0.55* 62 C PRINT 6,RTNP,NP,N0,JDEL 6 FORMAT(' HORIZONTAL DIFFUSION PARAMETERS'/ & ' EFFECTIVE ',6PF10.3,' MICROHERTZ AT WAVENUMBER ',I4/ & ' MAXIMUM WAVENUMBER FOR ZERO DIFFUSION ',I4/ & ' ORDER OF DIFFUSION ',I2) C-DBG CALL FLUSH(6) C JDELH=JDEL/2 NPD=MAX(NP-N0,0) DN1=2.*RTNP/FLOAT(NPD*(NPD+1))**JDELH I=0 DO 10 NM=0, 62 DO 10 M=0, 62 -NM ND=MAX(NM+M-N0,0) DN(I+1)=DN1*FLOAT(ND*(ND+1))**JDELH DN(I+2)=DN(I+1) I=I+2 10 CONTINUE C ENDIF C-DBG PRINT *,'DN COMPUTATION COMPLETED' C-DBG CALL FLUSH(6) CFPP$ NODEPCHK DO K=1, 28 DO I=3, 4032 W(I,K)= W(I,K)/(1.+DELTIM*DN(I)) X(I,K)= X(I,K)/(1.+DELTIM*DN(I)) Y(I,K)= Y(I,K)/(1.+DELTIM*DN(I)) RT(I,K)=RT(I,K)/(1.+DELTIM*DN(I)) ENDDO ENDDO C-DBG PRINT *,'WXY COMPUTATION COMPLETED' C-DBG CALL FLUSH(6) C DO K=1, 28 C DO I=3, 4032 C RT(I,K)=RT(I,K)/(1.+DELTIM*DN(I)) C ENDDO C ENDDO C-DBG PRINT *,'RT COMPUTATION COMPLETED' C-DBG CALL FLUSH(6) RETURN END CFPP$ NOCONCUR R SUBROUTINE ACCDIA(NLONX,A,DT,KD,GDA) C ACCUMULATE DIAGNOSTICS C C NLONX IS 1ST DIMENSION OF A C A IS ARRAY TO ACCUMULATE C DT IS FACTOR BY WHICH TO MULTIPLY BEFORE ACCUMULATING C KD IS DIAGNOSTIC NUMBER C GDA IS ACCUMULATION ARRAY C C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) C DIMENSION A(NLONX, 28 ) DIMENSION GDA(NWGDA,KDGDA) C IF(KD.GT.0.AND.KD.LE.KDGDA) THEN DO 20 K=1, 28 DO 10 I=1, 384 IK=I+ 384 *(K-1) GDA(IK,KD)=GDA(IK,KD)+A(I,K)*DT 10 CONTINUE 20 CONTINUE ENDIF C RETURN END CFPP$ NOCONCUR R SUBROUTINE GETDIA(J,L,A) C GET DIAGNOSTICS FROM DISK OR MEMORY C CALL SYNDIA OR ANOTHER GETDIA OR PUTDIA TO FINISH I/O C C J IS RECORD NUMBER C L IS RECORD LENGTH C A IS ARRAY OF LENGTH L TO GET C DIMENSION A(L) C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) C CCDGM A=GDD(J*L-L+1:J*L) C DO N=J*L-L+1,J*L A(N-(J*L-L+1)+1)=GDD(N) ENDDO RETURN C CCDG3 RC=UNIT(NTGDA) CCDG3 CALL SETPOS(NTGDA,3,(J-1)*L) CCDG3 BUFFERIN(NTGDA,0) (A(1),A(L)) CC RETURN C END CFPP$ NOCONCUR R SUBROUTINE PUTDIA(J,L,A) C PUT DIAGNOSTICS ONTO DISK OR MEMORY C CALL SYNDIA OR ANOTHER GETDIA OR PUTDIA TO FINISH I/O C C J IS RECORD NUMBER C L IS RECORD LENGTH C A IS ARRAY OF LENGTH L TO GET C DIMENSION A(L) C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) C CCDGM GDD(J*L-L+1:J*L)=A DO N=J*L-L+1,J*L GDD(N)=A(N-(J*L-L+1)+1) ENDDO RETURN C CCDG3 RC=UNIT(NTGDA) CCDG3 CALL SETPOS(NTGDA,3,(J-1)*L) CCDG3 BUFFEROUT(NTGDA,0) (A(1),A(L)) C RETURN C END CFPP$ NOCONCUR R SUBROUTINE SYNDIA C SYNCHRONIZE DIAGNOSTICS DISK C C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) C RETURN C CCDG3 RC=UNIT(NTGDA) CC RETURN C END SUBROUTINE WRIDIA(FHOUR,RHOUR,IDATE,SL,COLRAB,SLMASK, 1 TSEA,SMSOIL,SHELEG,STSOIL,TG3,CANOPY,ZORL,GESHEM,BENGSH, 2 DUSFC,DVSFC,DTSFC,DQSFC,FLUXR,CVAVG, 3 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,NDG) C INTEGER IDATE(4) DIMENSION SL( 28 ),COLRAB( 384 ) CSIB C...... DOWNWARD SW FLUXES FROM SW SIB RAD.. C .. SAVED FOR H2D FILE.... COMMON/SIBSW/ DFVBR( 384 , 47 ),DFNBR( 384 , 47 ), 1 DFVDR( 384 , 47 ),DFNDR( 384 , 47 ) CSIB CLD FORCE DIMENSION CFSW( 384 , 47 ,3) DIMENSION CFLW( 384 , 47 ,3) EQUIVALENCE (CFSW(1,1,1),CFLW(1,1,1)) CLD FORCE DIMENSION SLMASK( 384 , 47 ),TSEA( 384 , 47 ), 1 SMSOIL( 384 , 47 , 2 ),SHELEG( 384 , 47 ), 2 STSOIL( 384 , 47 , 2 ),CANOPY( 384 , 47 ), 3 TG3( 384 , 47 ), 4 ZORL( 384 , 47 ),GESHEM( 384 , 47 ) 5 ,BENGSH( 384 , 47 ) 6 ,DUSFC( 384 , 47 ),DVSFC( 384 , 47 ) 6 ,DTSFC( 384 , 47 ),DQSFC( 384 , 47 ) DIMENSION FLUXR( 384 , 47 ,25) DIMENSION CVAVG( 384 , 47 ) DIMENSION ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) DIMENSION INSLAT( 47 ),WGTLAT( 47 ) C COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) DIMENSION GDA(NWGDA) C PARAMETER(IPRS=1,ITEMP=11,IZNLW=33,IMERW=34,ISPHUM=51, $ IPCPR=59,ISNOWD=65,ICLDF=71,ICCLDF=72, $ ISLMSK=81,IZORL=83,IALBDO=84,ISOILM=144,ICEMSK=91, $ ILHFLX=121,ISHFLX=122,IZWS=124,IMWS=125,IGHFLX=155, $ IUSWFC=160,IDSWFC=161,IULWFC=162,IDLWFC=163, $ INSWFC=164,INLWFC=165, $ IDSWVB=166,IDSWVD=167,IDSWNB=168,IDSWND=169, $ ISGLYR=175,ICNPY=145, $ IDSWF=204,IDLWF=205,IUSWF=211,IULWF=212,ICPCPR=214) PARAMETER(ISFC=1,ITOA=8,IELEV=105, $ ISGLEV=107,IDBLS=111,I2DBLS=112,ICOLMN=200, $ ILCBL=212,ILCTL=213,ILCLYR=214, $ IMCBL=222,IMCTL=223,IMCLYR=224, $ IHCBL=232,IHCTL=233,IHCLYR=234) PARAMETER(INST=10,IAVG=3,IACC=4) PARAMETER(IFHOUR=1,IFDAY=2) PARAMETER(LONB= 384 /2,LATB= 47 *2) LOGICAL LBM( 384 , 47 ) CHARACTER G(200+ 384 * 47 *(16+1)/8) DIMENSION IDS(255) DIMENSION IENS(5) DIMENSION ICLYR(3),ICTL(3),ICBL(3),ITLCF(3) DATA ICLYR/IHCLYR,IMCLYR,ILCLYR/ DATA ICTL /IHCTL ,IMCTL ,ILCTL / DATA ICBL /IHCBL ,IMCBL ,ILCBL / DATA ITLCF/ITOA,ISFC,ICOLMN/ C DIMENSION WORK( 384 , 47 ),SLMSEP( 384 , 47 ), 1 WORK2( 384 , 47 , 28 +2/ 28 ), 1 WORKC( 384 ,20),IWORKC( 384 ) C REWIND NDG CALL IDSDEF(1,IDS) IENS(1)=1 IENS(2)=IENST IENS(3)=IENSI IENS(4)=1 IENS(5)=255 IYR=IDATE(4) IMO=IDATE(2) IDA=IDATE(3) IHR=IDATE(1) IFTIME=IFHOUR IFHR=NINT(FHOUR) ITHR=NINT(RHOUR) IF(ITHR.GT.255) THEN IFTIME=IFDAY IFHR=IFHR/24 ITHR=ITHR/24 ENDIF DHOUR=RHOUR-FHOUR IF(DHOUR.GT.0.) THEN RTIME=1./(3600.*DHOUR) ELSE RTIME=0. ENDIF DO J=1, 47 DO I=1, 384 SLMSEP(I,J)=SLMASK(I,J) ENDDO ENDDO CCDG3 SLMSEP=SLMASK CALL ROWSEP(SLMSEP) C CCDG3 WORK=TSEA DO J=1, 47 DO I=1, 384 WORK(I,J)=TSEA(I,J) ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,ITEMP,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) DO J = 1, 47 DO I = 1, 384 WORK(I,J) = SMSOIL(I,J,1) ENDDO ENDDO CALL ROWSEP(WORK) CCDG3 LBM=SLMSEP.EQ.1. DO J=1, 47 DO I=1, 384 LBM(I,J)=SLMSEP(I,J).EQ.1. ENDDO ENDDO CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 1,ISOILM,I2DBLS,0,10,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(ISOILM),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) DO J = 1, 47 DO I = 1, 384 WORK(I,J) = SMSOIL(I,J,2) ENDDO ENDDO CALL ROWSEP(WORK) CCDG3 LBM=SLMSEP.EQ.1. DO J=1, 47 DO I=1, 384 LBM(I,J)=SLMSEP(I,J).EQ.1. ENDDO ENDDO CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28,132, & ICEN,IGEN, & 1,ISOILM,I2DBLS,10,200,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(ISOILM),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=SHELEG DO J=1, 47 DO I=1, 384 WORK(I,J)=SHELEG(I,J) ENDDO ENDDO CALL ROWSEP(WORK) C LBM=WORK.GT.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,ISNOWD,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(ISNOWD),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) DO J = 1, 47 DO I = 1, 384 WORK(I,J) = STSOIL(I,J,1) ENDDO ENDDO CALL ROWSEP(WORK) CCDG3 LBM=SLMSEP.EQ.1. DO J=1, 47 DO I=1, 384 LBM(I,J)=SLMSEP(I,J).EQ.1. ENDDO ENDDO CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 1,ITEMP,I2DBLS,0,10,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) DO J = 1, 47 DO I = 1, 384 WORK(I,J) = STSOIL(I,J,2) ENDDO ENDDO CALL ROWSEP(WORK) CCDG3 LBM=SLMSEP.EQ.1. DO J=1, 47 DO I=1, 384 LBM(I,J)=SLMSEP(I,J).EQ.1. ENDDO ENDDO CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 1,ITEMP,I2DBLS,10,200,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=TG3 DO J=1, 47 DO I=1, 384 WORK(I,J)=TG3(I,J) ENDDO ENDDO CALL ROWSEP(WORK) CCDG3 LBM=SLMSEP.EQ.1. DO J=1, 47 DO I=1, 384 LBM(I,J)=SLMSEP(I,J).EQ.1. ENDDO ENDDO CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 1,ITEMP,IDBLS,0,300,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=ZORL*1.E-2 DO J=1, 47 DO I=1, 384 WORK(I,J)=ZORL(I,J)*1.E-2 ENDDO ENDDO CALL ROWSEP(WORK) c CCDG3 LBM=SLMSEP.EQ.0. c DO J=1, 47 c DO I=1, 384 c LBM(I,J)=SLMSEP(I,J).EQ.0. c ENDDO c ENDDO CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 1,IZORL,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,ITHR,0,INST,0,0,ICEN2,IDS(IZORL),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) IF(DHOUR.GT.0.) THEN CCDG3 WORK=GESHEM*1.E3*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=GESHEM(I,J)*1.E3*RTIME ENDDO ENDDO CALL ROWSEP(WORK) C LBM=WORK.GT.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IPCPR,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPCPR),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=BENGSH*1.E3*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=BENGSH(I,J)*1.E3*RTIME ENDDO ENDDO CALL ROWSEP(WORK) C LBM=WORK.GT.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,ICPCPR,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ICPCPR),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=DTSFC*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=DTSFC(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,ISHFLX,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ISHFLX),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=DUSFC*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=DUSFC(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IZWS,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IZWS),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=DVSFC*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=DVSFC(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IMWS,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IMWS),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=DQSFC*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=DQSFC(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,ILHFLX,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ILHFLX),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) C CALL GGINTF(FLUXR(1,1,17), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME*1.E2 DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME*1.E2 ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IALBDO,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IALBDO),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,1), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IULWF,ITOA,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IULWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,2), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IUSWF,ITOA,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IUSWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,18), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDSWF,ITOA,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,4), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDSWF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,3), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IUSWF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IUSWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,19), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDLWF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDLWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,20), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IULWF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IULWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) DO 813 K=5,7 DO 413 J=1, 47 DO 413 I=1, 384 IF(FLUXR(I,J,K).GT.0. E 0) THEN FLUXR(I,J,K+3) = FLUXR(I,J,K+3) / FLUXR(I,J,K) FLUXR(I,J,K+6) = FLUXR(I,J,K+6) / FLUXR(I,J,K) FLUXR(I,J,K) = FLUXR(I,J,K) * RTIME ENDIF 413 CONTINUE CALL CVINTF(FLUXR(1,1,K),FLUXR(1,1,K+3),FLUXR(1,1,K+6), 1 384 , 47 , 47 , 2 WORK2(1,1,1),WORK2(1,1,2),WORK2(1,1,3), 3 384 , 47 , 47 , 4 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 5 WORKC(1,1),WORKC(1,5),WORKC(1,9),WORKC(1,13), 6 WORKC(1,17),IWORKC,1,1,1) DO 513 J=1, 47 DO 513 I=1, 384 IF(FLUXR(I,J,K).GT.0. E 0) THEN FLUXR(I,J,K) = FLUXR(I,J,K) / RTIME FLUXR(I,J,K+3) = FLUXR(I,J,K+3) * FLUXR(I,J,K) FLUXR(I,J,K+6) = FLUXR(I,J,K+6) * FLUXR(I,J,K) ENDIF 513 CONTINUE CCDG3 WORK=WORK2(:,:,1)*1.E2 DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK2(I,J,1)*1.E2 ENDDO ENDDO CALL ROWSEP(WORK) CCDG3 LBM=WORK.GT.0. DO J=1, 47 DO I=1, 384 LBM(I,J)=WORK(I,J).GT.0. ENDDO ENDDO CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,ICLDF,ICLYR(K-4),0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ICLDF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=WORK2(:,:,2) DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK2(I,J,2)*1.E2 ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, CCDG3& 1,ISGLYR,ICTL(K-4),0,0,IYR,IMO,IDA,IHR, & 0,ISGLYR,ICTL(K-4),0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ISGLYR),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CCDG3 WORK=WORK2(:,:,3) DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK2(I,J,3)*1.E2 ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, CCDG3& 1,ISGLYR,ICBL(K-4),0,0,IYR,IMO,IDA,IHR, & 0,ISGLYR,ICBL(K-4),0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ISGLYR),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) 813 CONTINUE CCDG3 WORK=CVAVG*RTIME*1.E2 DO J=1, 47 DO I=1, 384 WORK(I,J)=CVAVG(I,J)*RTIME*1.E2 ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.GT.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,ICCLDF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ICCLDF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CLD FORCE CALL GGINTF(FLUXR(1,1,21), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCCLR WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IULWFC,ITOA,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IULWFC),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,22), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCCLR WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IUSWFC,ITOA,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IUSWFC),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,25), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCCLR WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDLWFC,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDLWFC),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,23), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCCLR WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDSWFC,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWFC),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(FLUXR(1,1,24), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCCLR WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IUSWFC,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IUSWFC),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) C..... COMPUTE SW CLOUD FORCING AT TOA (CLD-CLEAR), C FLIP SIGN SO POSITIVE MEANS CLD IS WARMING RELATIVE TO CLEAR DO 600 J=1, 47 DO 600 I=1, 384 CFSW(I,J,1) = - (FLUXR(I,J,2)-FLUXR(I,J,22)) 600 CONTINUE C..... COMPUTE CLOUD FORCING AT SFC (CLD-CLEAR) C AGAIN FLIP SIGN SO POSITIVE MEANS CLD IS WARMING RELATIVE TO CLEAR DO 601 J=1, 47 DO 601 I=1, 384 CFSW(I,J,2) =-(FLUXR(I,J,3)-FLUXR(I,J,4) 1 -(FLUXR(I,J,24)-FLUXR(I,J,23))) 601 CONTINUE C..... FLIP SIGN SO POSITIVE MEANS CLD IS WARMING RELATIVE TO CLEAR DO 602 J=1, 47 DO 602 I=1, 384 CFSW(I,J,3) = - (CFSW(I,J,2) - CFSW(I,J,1)) 602 CONTINUE DO 603 K=1,3 CALL GGINTF(CFSW (1,1,K), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCCLR WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,INSWFC,ITLCF(K),0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(INSWFC),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) 603 CONTINUE C..... COMPUTE LW CLOUD FORCING AT TOA (CLD-CLEAR), C FLIP SIGN SO POSITIVE MEANS CLD IS WARMING RELATIVE TO CLEAR DO 1600 J=1, 47 DO 1600 I=1, 384 CFLW(I,J,1) = - (FLUXR(I,J,1)-FLUXR(I,J,21)) 1600 CONTINUE C..... COMPUTE CLOUD FORCING AT SFC (CLD-CLEAR) C AGAIN FLIP SIGN SO POSITIVE MEANS CLD IS WARMING RELATIVE TO CLEAR DO 1601 J=1, 47 DO 1601 I=1, 384 CFLW(I,J,2) = - (FLUXR(I,J,25)-FLUXR(I,J,19)) 1601 CONTINUE C..... FLIP SIGN SO POSITIVE MEANS CLD IS WARMING RELATIVE TO CLEAR DO 1602 J=1, 47 DO 1602 I=1, 384 CFLW(I,J,3) = - (CFLW(I,J,2) - CFLW(I,J,1)) 1602 CONTINUE DO 1603 K=1,3 CALL GGINTF(CFLW (1,1,K), 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCCLR WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,INLWFC,ITLCF(K),0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(INLWFC),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) 1603 CONTINUE CLD FORCE C.. CSIB CALL GGINTF(DFVBR, 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDSWVB,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWVB),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(DFVDR, 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDSWVD,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWVD),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(DFNBR, 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDSWNB,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWNB),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CALL GGINTF(DFNDR, 384 , 47 , 47 , 1 WORK, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) CCDG3 WORK=WORK*RTIME DO J=1, 47 DO I=1, 384 WORK(I,J)=WORK(I,J)*RTIME ENDDO ENDDO CALL ROWSEP(WORK) CC LBM=WORK.NE.0. CALL GRIBIT(WORK,LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, & 0,IDSWND,ISFC,0,0,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWND),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) CSIB C DO 750 KD=1,KDGDA C DO 720 J=1,NRGDA KGDA=(J-1)*KDGDA+KD CALL GETDIA(KGDA,NWGDA,GDA) CALL SYNDIA IGDA=0 DO 710 K=1, 28 DO 710 I=1, 384 IGDA=IGDA+1 WORK2(I,J,K)=GDA(IGDA)*RTIME 710 CONTINUE 720 CONTINUE IPU=IPUGDA(KD) IBM=IBMGDA(KD) DO 730 K=1, 28 ISL=NINT(SL(K)*1.E4) CALL ROWSEP(WORK2(1,1,K)) CCDG3 IF(IBM.NE.0) LBM=WORK2(:,:,K).NE.0. IF(IBM.NE.0) THEN DO J=1, 47 DO I=1, 384 LBM(I,J)=WORK2(I,J,K).NE.0. ENDDO ENDDO ENDIF CALL GRIBIT(WORK2(1,1,K),LBM,4,LONB,LATB,16,COLRAB,28, & 132,ICEN,IGEN, CCDG3& IBM,IPU,ISGLEV,0,ISL,IYR,IMO,IDA,IHR, & 0,IPU,ISGLEV,0,ISL,IYR,IMO,IDA,IHR, & IFTIME,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPU),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NDG,LG,G) 730 CONTINUE C 750 CONTINUE ENDIF C CLOSE(NDG) C RETURN END SUBROUTINE INDDIA C SET LEVELS AND INDICES FOR DIAGNOSTICS C C USE KD AS DEFINED BELOW WHEN USING SUBROUTINE ACCDIA C C KD CNMGDA C 1 DTLARG C 2 DTCONV C 3 DQCONV C 4 DTSHAL C 5 DQSHAL C 6 DTVRDF C 7 DUVRDF C 8 DVVRDF C 9 DQVRDF C 10 DTHSW C 11 DTHLW C 12 CLOUD C 13 CVCLD C C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) C C SET IDENTIFICATION INDEX C C LARGE-SCALE HEATING CNMGDA( 1)='DTLARG ' IPUGDA( 1)=241 IBMGDA( 1)=0 C DEEP CONVECTIVE HEATING CNMGDA( 2)='DTCONV ' IPUGDA( 2)=242 IBMGDA( 2)=0 C DEEP CONVECTIVE MOISTENING CNMGDA( 3)='DQCONV ' IPUGDA( 3)=243 IBMGDA( 3)=0 C SHALLOW CONVECTIVE HEATING CNMGDA( 4)='DTSHAL ' IPUGDA( 4)=244 IBMGDA( 4)=0 C SHALLOW CONVECTIVE MOISTENING CNMGDA( 5)='DQSHAL ' IPUGDA( 5)=245 IBMGDA( 5)=0 C VERTICAL DIFFUSION OF TEMPERATURE CNMGDA( 6)='DTVRDF ' IPUGDA( 6)=246 IBMGDA( 6)=0 C VERTICAL DIFFUSION OF ZONAL WIND CNMGDA( 7)='DUVRDF ' IPUGDA( 7)=247 IBMGDA( 7)=0 C VERTICAL DIFFUSION OF MERIDIONAL WIND CNMGDA( 8)='DVVRDF ' IPUGDA( 8)=248 IBMGDA( 8)=0 C VERTICAL DIFFUSION OF MOISTURE CNMGDA( 9)='DQVRDF ' IPUGDA( 9)=249 IBMGDA( 9)=0 C SHORT WAVE RADIATION HEATING CNMGDA(10)='DTHSW ' IPUGDA(10)=250 IBMGDA(10)=0 C LONG WAVE RADIATION HEATING CNMGDA(11)='DTHLW ' IPUGDA(11)=251 IBMGDA(11)=0 C CLOUD AMOUNT CNMGDA(12)='CLOUD ' IPUGDA(12)=71 IBMGDA(12)=0 C CONVECTIVE CLOUD AMOUNT CNMGDA(13)='CVCLD ' IPUGDA(13)=72 IBMGDA(13)=0 C RETURN END SUBROUTINE ZERDIA(RHOUR) C C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) DIMENSION GDA(NWGDA*KDGDA) PRINT 91,RHOUR CC OPEN(UNIT=NTGDA,ACCESS='DIRECT',RECL=8*NWGDA*KDGDA) CCDG3 GDA=0. DO N=1,NWGDA*KDGDA GDA(N)=0. ENDDO DO 30 JR=1,NRGDA CALL PUTDIA(JR,NWGDA*KDGDA,GDA) 30 CONTINUE CALL SYNDIA C RETURN 91 FORMAT(' ZERO FULL PHYSICS TENDENCY DIAGNOSTICS AT FHOUR ',F6.1) END SUBROUTINE MLTDIA(FAC) C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) DIMENSION GDA(NWGDA*KDGDA) DO 30 JR=1,NRGDA CALL GETDIA(JR,NWGDA*KDGDA,GDA) CCDG3 GDA=FAC*GDA DO N=1,NWGDA*KDGDA GDA(N)=FAC*GDA(N) ENDDO CALL PUTDIA(JR,NWGDA*KDGDA,GDA) 30 CONTINUE CALL SYNDIA RETURN END SUBROUTINE FAX(IFAX,N,MODE) SAVE DIMENSION IFAX(10) C NN=N IF (IABS(MODE).EQ.1) GO TO 10 IF (IABS(MODE).EQ.8) GO TO 10 NN=N/2 IF ((NN+NN).EQ.N) GO TO 10 IFAX(1)=-99 RETURN 10 K=1 C TEST FOR FACTORS OF 4 20 IF (MOD(NN,4).NE.0) GO TO 30 K=K+1 IFAX(K)=4 NN=NN/4 IF (NN.EQ.1) GO TO 80 GO TO 20 C TEST FOR EXTRA FACTOR OF 2 30 IF (MOD(NN,2).NE.0) GO TO 40 K=K+1 IFAX(K)=2 NN=NN/2 IF (NN.EQ.1) GO TO 80 C TEST FOR FACTORS OF 3 40 IF (MOD(NN,3).NE.0) GO TO 50 K=K+1 IFAX(K)=3 NN=NN/3 IF (NN.EQ.1) GO TO 80 GO TO 40 C NOW FIND REMAINING FACTORS 50 L=5 INC=2 C INC ALTERNATELY TAKES ON VALUES 2 AND 4 60 IF (MOD(NN,L).NE.0) GO TO 70 K=K+1 IFAX(K)=L NN=NN/L IF (NN.EQ.1) GO TO 80 GO TO 60 70 L=L+INC INC=6-INC GO TO 60 80 IFAX(1)=K-1 C IFAX(1) CONTAINS NUMBER OF FACTORS C IFAX(1) CONTAINS NUMBER OF FACTORS NFAX=IFAX(1) C SORT FACTORS INTO ASCENDING ORDER IF (NFAX.EQ.1) GO TO 110 DO 100 II=2,NFAX ISTOP=NFAX+2-II DO 90 I=2,ISTOP IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 ITEM=IFAX(I) IFAX(I)=IFAX(I+1) IFAX(I+1)=ITEM 90 CONTINUE 100 CONTINUE 110 CONTINUE RETURN END SUBROUTINE FFTRIG(TRIGS,N,MODE) SAVE DIMENSION TRIGS(1) C PI=2.0*ASIN(1.0) IMODE=IABS(MODE) NN=N IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 DEL=(PI+PI)/FLOAT(NN) L=NN+NN DO 10 I=1,L,2 ANGLE=0.5 E 0*FLOAT(I-1)*DEL TRIGS(I)=COS(ANGLE) TRIGS(I+1)=SIN(ANGLE) 10 CONTINUE IF (IMODE.EQ.1) RETURN IF (IMODE.EQ.8) RETURN DEL=0.5 E 0*DEL NH=(NN+1)/2 L=NH+NH LA=NN+NN DO 20 I=1,L,2 ANGLE=0.5 E 0*FLOAT(I-1)*DEL TRIGS(LA+I)=COS(ANGLE) TRIGS(LA+I+1)=SIN(ANGLE) 20 CONTINUE IF (IMODE.LE.3) RETURN DEL=0.5 E 0*DEL LA=LA+NN IF (MODE.EQ.5) GO TO 40 DO 30 I=2,NN ANGLE=FLOAT(I-1)*DEL TRIGS(LA+I)=2.0 E 0*SIN(ANGLE) 30 CONTINUE RETURN 40 CONTINUE DEL=0.5 E 0*DEL DO 50 I=2,N ANGLE=FLOAT(I-1)*DEL TRIGS(LA+I)=SIN(ANGLE) 50 CONTINUE RETURN END SUBROUTINE VPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,LA) SAVE DIMENSION A(N),B(N),C(N),D(N),TRIGS(N) DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, * SIN72/0.951056516295154/,COS72/0.309016994374947/, * SIN60/0.866025403784437/ C M=N/IFAC IINK=M*INC1 JINK=LA*INC2 JUMP=(IFAC-1)*JINK IBASE=0 JBASE=0 IGO=IFAC-1 IF (IGO.GT.4) RETURN GO TO (10,50,90,130),IGO C C CODING FOR FACTOR 2 C 10 IA=1 JA=1 IB=IA+IINK JB=JA+JINK DO 20 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 15 IJK=1,LOT C(JA+J)=A(IA+I)+A(IB+I) D(JA+J)=B(IA+I)+B(IB+I) C(JB+J)=A(IA+I)-A(IB+I) D(JB+J)=B(IA+I)-B(IB+I) I=I+INC3 J=J+INC4 15 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 20 CONTINUE IF (LA.EQ.M) RETURN LA1=LA+1 JBASE=JBASE+JUMP DO 40 K=LA1,M,LA KB=K+K-2 C1=TRIGS(KB+1) S1=TRIGS(KB+2) DO 30 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 25 IJK=1,LOT C(JA+J)=A(IA+I)+A(IB+I) D(JA+J)=B(IA+I)+B(IB+I) C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) I=I+INC3 J=J+INC4 25 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 30 CONTINUE JBASE=JBASE+JUMP 40 CONTINUE RETURN C C CODING FOR FACTOR 3 C 50 IA=1 JA=1 IB=IA+IINK JB=JA+JINK IC=IB+IINK JC=JB+JINK DO 60 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 55 IJK=1,LOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) C(JB+J)=(A(IA+I)-0.5 E 0*(A(IB+I)+A(IC+I))) X -(SIN60*(B(IB+I)-B(IC+I))) C(JC+J)=(A(IA+I)-0.5 E 0*(A(IB+I)+A(IC+I))) X +(SIN60*(B(IB+I)-B(IC+I))) D(JB+J)=(B(IA+I)-0.5 E 0*(B(IB+I)+B(IC+I))) X +(SIN60*(A(IB+I)-A(IC+I))) D(JC+J)=(B(IA+I)-0.5 E 0*(B(IB+I)+B(IC+I))) X -(SIN60*(A(IB+I)-A(IC+I))) I=I+INC3 J=J+INC4 55 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 60 CONTINUE IF (LA.EQ.M) RETURN LA1=LA+1 JBASE=JBASE+JUMP DO 80 K=LA1,M,LA KB=K+K-2 KC=KB+KB C1=TRIGS(KB+1) S1=TRIGS(KB+2) C2=TRIGS(KC+1) S2=TRIGS(KC+2) DO 70 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 65 IJK=1,LOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) C(JB+J)= * C1*((A(IA+I)-0.5 E 0*(A(IB+I)+A(IC+I))) X -(SIN60*(B(IB+I)-B(IC+I)))) * -S1*((B(IA+I)-0.5 E 0*(B(IB+I)+B(IC+I))) X +(SIN60*(A(IB+I)-A(IC+I)))) D(JB+J)= * S1*((A(IA+I)-0.5 E 0*(A(IB+I)+A(IC+I))) X -(SIN60*(B(IB+I)-B(IC+I)))) * +C1*((B(IA+I)-0.5 E 0*(B(IB+I)+B(IC+I))) X +(SIN60*(A(IB+I)-A(IC+I)))) C(JC+J)= * C2*((A(IA+I)-0.5 E 0*(A(IB+I)+A(IC+I))) X +(SIN60*(B(IB+I)-B(IC+I)))) * -S2*((B(IA+I)-0.5 E 0*(B(IB+I)+B(IC+I))) X -(SIN60*(A(IB+I)-A(IC+I)))) D(JC+J)= * S2*((A(IA+I)-0.5 E 0*(A(IB+I)+A(IC+I))) X +(SIN60*(B(IB+I)-B(IC+I)))) * +C2*((B(IA+I)-0.5 E 0*(B(IB+I)+B(IC+I))) X -(SIN60*(A(IB+I)-A(IC+I)))) I=I+INC3 J=J+INC4 65 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 70 CONTINUE JBASE=JBASE+JUMP 80 CONTINUE RETURN C C CODING FOR FACTOR 4 C 90 IA=1 JA=1 IB=IA+IINK JB=JA+JINK IC=IB+IINK JC=JB+JINK ID=IC+IINK JD=JC+JINK DO 100 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 95 IJK=1,LOT C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) I=I+INC3 J=J+INC4 95 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 100 CONTINUE IF (LA.EQ.M) RETURN LA1=LA+1 JBASE=JBASE+JUMP DO 120 K=LA1,M,LA KB=K+K-2 KC=KB+KB KD=KC+KB C1=TRIGS(KB+1) S1=TRIGS(KB+2) C2=TRIGS(KC+1) S2=TRIGS(KC+2) C3=TRIGS(KD+1) S3=TRIGS(KD+2) DO 110 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 105 IJK=1,LOT C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) C(JC+J)= * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) D(JC+J)= * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) C(JB+J)= * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) D(JB+J)= * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) C(JD+J)= * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) D(JD+J)= * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) I=I+INC3 J=J+INC4 105 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 110 CONTINUE JBASE=JBASE+JUMP 120 CONTINUE RETURN C C CODING FOR FACTOR 5 C 130 IA=1 JA=1 IB=IA+IINK JB=JA+JINK IC=IB+IINK JC=JB+JINK ID=IC+IINK JD=JC+JINK IE=ID+IINK JE=JD+JINK DO 140 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 135 IJK=1,LOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) I=I+INC3 J=J+INC4 135 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 140 CONTINUE IF (LA.EQ.M) RETURN LA1=LA+1 JBASE=JBASE+JUMP DO 160 K=LA1,M,LA KB=K+K-2 KC=KB+KB KD=KC+KB KE=KD+KB C1=TRIGS(KB+1) S1=TRIGS(KB+2) C2=TRIGS(KC+1) S2=TRIGS(KC+2) C3=TRIGS(KD+1) S3=TRIGS(KD+2) C4=TRIGS(KE+1) S4=TRIGS(KE+2) DO 150 L=1,LA I=IBASE J=JBASE CDIR$ IVDEP DO 145 IJK=1,LOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) C(JB+J)= * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) D(JB+J)= * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) C(JE+J)= * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) D(JE+J)= * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) C(JC+J)= * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) D(JC+J)= * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) C(JD+J)= * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) D(JD+J)= * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) I=I+INC3 J=J+INC4 145 CONTINUE IBASE=IBASE+INC1 JBASE=JBASE+INC2 150 CONTINUE JBASE=JBASE+JUMP 160 CONTINUE RETURN END SUBROUTINE FFT99M(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) SAVE DIMENSION A(N),WORK(N),TRIGS(N),IFAX(1) C NFAX=IFAX(1) NX=N NH=N/2 INK=INC+INC IF (ISIGN.EQ.+1) GO TO 30 C C IF NECESSARY, TRANSFER DATA TO WORK AREA IGO=50 IF (MOD(NFAX,2).EQ.1) GOTO 40 IBASE=1 JBASE=1 DO 20 L=1,LOT I=IBASE J=JBASE CDIR$ IVDEP DO 10 M=1,N WORK(J)=A(I) I=I+INC J=J+1 10 CONTINUE IBASE=IBASE+JUMP JBASE=JBASE+NX 20 CONTINUE C IGO=60 GO TO 40 C C PREPROCESSING (ISIGN=+1) C ------------------------ C 30 CONTINUE CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) IGO=60 C C COMPLEX TRANSFORM C ----------------- C 40 CONTINUE IA=1 LA=1 DO 80 K=1,NFAX IF (IGO.EQ.60) GO TO 60 50 CONTINUE CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) IGO=60 GO TO 70 60 CONTINUE CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) IGO=50 70 CONTINUE LA=LA*IFAX(K+1) 80 CONTINUE C IF (ISIGN.EQ.-1) GO TO 130 C C IF NECESSARY, TRANSFER DATA FROM WORK AREA IF (MOD(NFAX,2).EQ.1) GO TO 110 IBASE=1 JBASE=1 DO 100 L=1,LOT I=IBASE J=JBASE CDIR$ IVDEP DO 90 M=1,N A(J)=WORK(I) I=I+1 J=J+INC 90 CONTINUE IBASE=IBASE+NX JBASE=JBASE+JUMP 100 CONTINUE C C FILL IN ZEROS AT END 110 CONTINUE GO TO 140 C C POSTPROCESSING (ISIGN=-1): C -------------------------- C 130 CONTINUE CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) C 140 CONTINUE RETURN END SUBROUTINE FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) SAVE C SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 C (SPECTRAL TO GRIDPOINT TRANSFORM) C DIMENSION A(N),WORK(N),TRIGS(N) C NH=N/2 NX=N INK=INC+INC C C A(0) A(N/2) IA=1 IB=N*INC+1 JA=1 JB=2 CDIR$ IVDEP DO 10 L=1,LOT WORK(JA)=A(IA) WORK(JB)=A(IA) IA=IA+JUMP IB=IB+JUMP JA=JA+NX JB=JB+NX 10 CONTINUE C C REMAINING WAVENUMBERS IABASE=2*INC+1 IBBASE=(N-2)*INC+1 JABASE=3 JBBASE=N-1 C DO 30 K=3,NH,2 IA=IABASE IB=IBBASE JA=JABASE JB=JBBASE C=TRIGS(N+K) S=TRIGS(N+K+1) CDIR$ IVDEP DO 20 L=1,LOT WORK(JA)=(A(IA)+A(IB))- * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) WORK(JB)=(A(IA)+A(IB))+ * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ * (A(IA+INC)-A(IB+INC)) WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- * (A(IA+INC)-A(IB+INC)) IA=IA+JUMP IB=IB+JUMP JA=JA+NX JB=JB+NX 20 CONTINUE IABASE=IABASE+INK IBBASE=IBBASE-INK JABASE=JABASE+2 JBBASE=JBBASE-2 30 CONTINUE C IF (IABASE.NE.IBBASE) GO TO 50 C WAVENUMBER N/4 (IF IT EXISTS) IA=IABASE JA=JABASE CDIR$ IVDEP DO 40 L=1,LOT WORK(JA)=2.0 E 0*A(IA) WORK(JA+1)=-2.0 E 0*A(IA+INC) IA=IA+JUMP JA=JA+NX 40 CONTINUE C 50 CONTINUE RETURN END SUBROUTINE FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) SAVE C SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 C (GRIDPOINT TO SPECTRAL TRANSFORM) C DIMENSION WORK(N),A(N),TRIGS(N) C NH=N/2 NX=N INK=INC+INC C C A(0) A(N/2) SCALE=1.0 E 0/FLOAT(N) IA=1 IB=2 JA=1 JB=N*INC+1 CDIR$ IVDEP DO 10 L=1,LOT A(JA)=SCALE*(WORK(IA)+WORK(IB)) A(JA+INC)=0.0 E 0 IA=IA+NX IB=IB+NX JA=JA+JUMP JB=JB+JUMP 10 CONTINUE C C REMAINING WAVENUMBERS SCALE=0.5 E 0*SCALE IABASE=3 IBBASE=N-1 JABASE=2*INC+1 JBBASE=(N-2)*INC+1 C DO 30 K=3,NH,2 IA=IABASE IB=IBBASE JA=JABASE JB=JBBASE C=TRIGS(N+K) S=TRIGS(N+K+1) CDIR$ IVDEP DO 20 L=1,LOT A(JA)=SCALE*((WORK(IA)+WORK(IB)) * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) A(JB)=SCALE*((WORK(IA)+WORK(IB)) * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) * +(WORK(IB+1)-WORK(IA+1))) A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) * -(WORK(IB+1)-WORK(IA+1))) IA=IA+NX IB=IB+NX JA=JA+JUMP JB=JB+JUMP 20 CONTINUE IABASE=IABASE+2 IBBASE=IBBASE-2 JABASE=JABASE+INK JBBASE=JBBASE-INK 30 CONTINUE C IF (IABASE.NE.IBBASE) GO TO 50 C WAVENUMBER N/4 (IF IT EXISTS) IA=IABASE JA=JABASE SCALE=2.0 E 0*SCALE CDIR$ IVDEP DO 40 L=1,LOT A(JA)=SCALE*WORK(IA) A(JA+INC)=-SCALE*WORK(IA+1) IA=IA+NX JA=JA+JUMP 40 CONTINUE C 50 CONTINUE RETURN END CFPP$ NOCONCUR R SUBROUTINE FTI_LONF (A, B, LOT, ISIGN) PARAMETER (LOTMIN= 64 ,LOTMAX= 64 ,NCPU=1) DIMENSION A( 386 ,LOT) DIMENSION B( 386 ,LOT) C DIMENSION WORK( 192 ,LOTMAX,2), AL( 195 ,LOTMAX) COMMON /COM_LONF/ITEST,JUMP,IFAX(20),TRIGS( 192 ,2) C CCC CMIC$ GUARD 21 CCC PART BETWEEN GUARDS MADE INTO SR GFT_LONF. CCC 4 DEC 1990 M. ROZWODOSKI CCC CMIC$ END GUARD 21 C C IF (ISIGN .EQ. 1) THEN C C MULTIPLE FAST FOURIER TRANSFORM - SYNTHESIS. ISIGN=1 C GOOD FOR ZONAL WAVE NUMBER 62 . C C DIMENSION A( 192 ,LOT) C C INPUT - LOT SETS OF COMPLEX COEFFICIENTS IN C A(1,J), A(2,J), ..., A( 63 *2,J), J=1,...,LOT. C A( 63 *2+1,J), ..., A( 192 ,J), J=1,...,LOT ARE NOT SET C BEFORE CALL FFT_LONF. C C OUTPUT - LOT SETS OF GRID VALUES IN C A(1,J), A(2,J), ..., A( 192 ,J), J=1,...,LOT. C NLOT=MAX0(LOT/NCPU,LOTMIN) NLOT=MIN0(NLOT ,LOTMAX) CRAYCMIC$ DO ALL PRIVATE(AL,WORK,LOTS) SHARED(A,TRIGS,IFAX,JUMP) AUTOSCO DO 460 I=1,LOT,NLOT LOTS = MIN0(NLOT, LOT-I+1) DO 360 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 320 L=1, 126 AL(L,J-I+1) = A(L+LOFF,K) 320 CONTINUE DO 340 L= 127 , 194 AL(L,J-I+1) = 0.0 340 CONTINUE 360 CONTINUE C C CALL CRAY FFT FOR SYSTHESIS. C C-T90 IF(1.EQ.1) THEN C-T90 CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 ELSE C-CRA CALL RFFTMLT(AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 ENDIF CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C DO 440 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 420 L=1, 192 A(L+LOFF,K) = AL(L,J-I+1) 420 CONTINUE 440 CONTINUE 460 CONTINUE C ENDIF C C IF (ISIGN .EQ. -1) THEN C C MULTIPLE FAST FOURIER TRANSFORM - ANALYSIS. ISIGN=-1 C GOOD FOR ZONAL WAVE NUMBER 62 . C C DIMENSION A( 192 ,LOT), B( 192 ,LOT) C C INPUT - LOT SETS OF GRID VALUES IN C A(1,J), A(2,J), ..., A( 192 ,J), J=1,...,LOT. C A ARRAY IS NOT CHANGED BY SR FFT_LONF. C C OUTPUT - LOT SETS OF COMPLEX COEFFICIENTS IN C B(1,J), B(2,J), ..., B( 63 *2,J), J=1,...,LOT. C B( 63 *2+1,J), ..., B( 192 ,J), J=1,...,LOT ARE NOT SET. C NLOT=MAX0(LOT/NCPU,LOTMIN) NLOT=MIN0(NLOT ,LOTMAX) CRAYCMIC$ DO ALL PRIVATE(AL,WORK,LOTS) SHARED(A,B,TRIGS,IFAX,JUMP) AUTOS DO 660 I=1,LOT,NLOT LOTS = MIN0(NLOT, LOT-I+1) DO 560 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 520 L=1, 192 AL(L,J-I+1) = A(L+LOFF,K) 520 CONTINUE 560 CONTINUE C C CALL CRAY FFT FOR ANALYSIS. C CALL FFT777 (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 IF(1.EQ.1) THEN C-T90 CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 ELSE C-CRA CALL RFFTMLT(AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 ENDIF CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C DO 640 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 620 L=1, 126 B(L+LOFF,K) = AL(L,J-I+1) 620 CONTINUE 640 CONTINUE 660 CONTINUE C ENDIF C RETURN END CFPP$ NOCONCUR R SUBROUTINE GFT_LONF C COMMON /COM_LONF/ITEST,JUMP,IFAX(20),TRIGS( 192 ,2) C CCC DATA ITEST/0/ CCC CMIC$ GUARD 21 CCC IF (ITEST.EQ.0) THEN ITEST=1 JUMP = 192 +3 C CALL SET777 (TRIGS, IFAX, 192 ) C-T90 IF(1.NE.1) THEN C-CRA CALL FFTFAX ( 192 ,IFAX,TRIGS) C-T90 ELSE C-T90 CALL FAX (IFAX, 192 ,3) C-T90 CALL FFTRIG (TRIGS, 192 ,3) C-T90 ENDIF CALL FAX (IFAX, 192 ,3) CALL FFTRIG (TRIGS, 192 ,3) IF (IFAX(1) .EQ. -99) PRINT 120 IF (IFAX(1) .EQ. -99) STOP 120 FORMAT (' ERROR IN GFT_LONF. 192 NOT FACTORABLE. ') PRINT 140, JUMP 140 FORMAT (' FFTFAX CALLED IN GFT_LONF. LONF = 192 ', X ' JUMP =', I5 ) CCC ENDIF CCC CMIC$ END GUARD 21 C RETURN END CFPP$ NOCONCUR R SUBROUTINE FTI_LONB (A, B, LOT, ISIGN) PARAMETER (LOTMIN= 64 ,LOTMAX= 64 ,NCPU=1) DIMENSION A( 386 ,LOT) DIMENSION B( 386 ,LOT) C DIMENSION WORK( 192 ,LOTMAX,2), AL( 195 ,LOTMAX) COMMON /COM_LONB/ITEST,JUMP,IFAX(20),TRIGS( 192 ,2) C CCC PART BETWEEN GUARDS MADE INTO SR GFT_LONB. CCC 4 DEC 1990 M. ROZWODOSKI C C IF (ISIGN .EQ. 1) THEN C C MULTIPLE FAST FOURIER TRANSFORM - SYNTHESIS. ISIGN=1 C GOOD FOR ZONAL WAVE NUMBER 62 . C C DIMENSION A( 192 ,LOT) C C INPUT - LOT SETS OF COMPLEX COEFFICIENTS IN C A(1,J), A(2,J), ..., A( 63 *2,J), J=1,...,LOT. C A( 63 *2+1,J), ..., A( 192 ,J), J=1,...,LOT ARE NOT SET C BEFORE CALL FFT_LONB. C C OUTPUT - LOT SETS OF GRID VALUES IN C A(1,J), A(2,J), ..., A( 192 ,J), J=1,...,LOT. C NLOT=MAX0(LOT/NCPU,LOTMIN) NLOT=MIN0(NLOT ,LOTMAX) DO 460 I=1,LOT,NLOT LOTS = MIN0(NLOT, LOT-I+1) DO 360 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 320 L=1, 126 AL(L,J-I+1) = A(L+LOFF,K) 320 CONTINUE DO 340 L= 127 , 194 AL(L,J-I+1) = 0.0 340 CONTINUE 360 CONTINUE C C CALL CRAY FFT FOR SYSTHESIS. C CALL FFT777 (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 IF(1.EQ.1) THEN C-T90 CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 ELSE C-CRA CALL RFFTMLT(AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 ENDIF CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C DO 440 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 420 L=1, 192 A(L+LOFF,K) = AL(L,J-I+1) 420 CONTINUE 440 CONTINUE 460 CONTINUE C ENDIF C C IF (ISIGN .EQ. -1) THEN C C MULTIPLE FAST FOURIER TRANSFORM - ANALYSIS. ISIGN=-1 C GOOD FOR ZONAL WAVE NUMBER 62 . C C DIMENSION A( 192 ,LOT), B( 192 ,LOT) C C INPUT - LOT SETS OF GRID VALUES IN C A(1,J), A(2,J), ..., A( 192 ,J), J=1,...,LOT. C A ARRAY IS NOT CHANGED BY SR FFT_LONB. C C OUTPUT - LOT SETS OF COMPLEX COEFFICIENTS IN C B(1,J), B(2,J), ..., B( 63 *2,J), J=1,...,LOT. C B( 63 *2+1,J), ..., B( 192 ,J), J=1,...,LOT ARE NOT SET. C NLOT=MAX0(LOT/NCPU,LOTMIN) NLOT=MIN0(NLOT ,LOTMAX) DO 660 I=1,LOT,NLOT LOTS = MIN0(NLOT, LOT-I+1) DO 560 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 520 L=1, 192 AL(L,J-I+1) = A(L+LOFF,K) 520 CONTINUE 560 CONTINUE C C CALL CRAY FFT FOR ANALYSIS. C CALL FFT777 (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 IF(1.EQ.1) THEN C-T90 CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 ELSE C-CRA CALL RFFTMLT(AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 ENDIF CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C DO 640 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 620 L=1, 126 B(L+LOFF,K) = AL(L,J-I+1) 620 CONTINUE 640 CONTINUE 660 CONTINUE C ENDIF C RETURN END CFPP$ NOCONCUR R SUBROUTINE GFT_LONB C COMMON /COM_LONB/ITEST,JUMP,IFAX(20),TRIGS( 192 ,2) C CCC DATA ITEST/0/ CCC IF (ITEST.EQ.0) THEN ITEST=1 JUMP = 192 +3 C CALL SET777 (TRIGS, IFAX, 192 ) C-T90 IF(1.NE.1) THEN C-CRA CALL FFTFAX ( 192 ,IFAX,TRIGS) C-T90 ELSE C-T90 CALL FAX (IFAX, 192 ,3) C-T90 CALL FFTRIG (TRIGS, 192 ,3) C-T90 ENDIF CALL FAX (IFAX, 192 ,3) CALL FFTRIG (TRIGS, 192 ,3) IF (IFAX(1) .EQ. -99) PRINT 120 IF (IFAX(1) .EQ. -99) STOP 120 FORMAT (' ERROR IN GFT_LONB. 192 NOT FACTORABLE. ') PRINT 140, JUMP 140 FORMAT (' FFTFAX CALLED IN GFT_LONB. LONF = 192 ', X ' JUMP =', I5 ) CCC ENDIF C RETURN END CFPP$ NOCONCUR R SUBROUTINE FTI_LONR (A, B, LOT, ISIGN) PARAMETER (LOTMIN= 64 ,LOTMAX= 64 ,NCPU=1) DIMENSION A( 386 ,LOT) DIMENSION B( 386 ,LOT) C DIMENSION WORK( 192 ,LOTMAX,2), AL( 195 ,LOTMAX) COMMON /COM_LONR/ITEST,JUMP,IFAX(20),TRIGS( 192 ,2) C CCC PART BETWEEN GUARDS MADE INTO SR GFT_LONR. CCC 4 DEC 1990 M. ROZWODOSKI C C IF (ISIGN .EQ. 1) THEN C C MULTIPLE FAST FOURIER TRANSFORM - SYNTHESIS. ISIGN=1 C GOOD FOR ZONAL WAVE NUMBER 62 . C C DIMENSION A( 192 ,LOT) C C INPUT - LOT SETS OF COMPLEX COEFFICIENTS IN C A(1,J), A(2,J), ..., A( 63 *2,J), J=1,...,LOT. C A( 63 *2+1,J), ..., A( 192 ,J), J=1,...,LOT ARE NOT SET C BEFORE CALL FFT_LONR. C C OUTPUT - LOT SETS OF GRID VALUES IN C A(1,J), A(2,J), ..., A( 192 ,J), J=1,...,LOT. C NLOT=MAX0(LOT/NCPU,LOTMIN) NLOT=MIN0(NLOT ,LOTMAX) DO 460 I=1,LOT,NLOT LOTS = MIN0(NLOT, LOT-I+1) DO 360 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 320 L=1, 126 AL(L,J-I+1) = A(L+LOFF,K) 320 CONTINUE DO 340 L= 127 , 194 AL(L,J-I+1) = 0.0 340 CONTINUE 360 CONTINUE C C CALL CRAY FFT FOR SYSTHESIS. C CALL FFT777 (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 IF(1.EQ.1) THEN C-T90 CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 ELSE C-CRA CALL RFFTMLT(AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C-T90 ENDIF CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,1) C DO 440 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 420 L=1, 192 A(L+LOFF,K) = AL(L,J-I+1) 420 CONTINUE 440 CONTINUE 460 CONTINUE C ENDIF C C IF (ISIGN .EQ. -1) THEN C C MULTIPLE FAST FOURIER TRANSFORM - ANALYSIS. ISIGN=-1 C GOOD FOR ZONAL WAVE NUMBER 62 . C C DIMENSION A( 192 ,LOT), B( 192 ,LOT) C C INPUT - LOT SETS OF GRID VALUES IN C A(1,J), A(2,J), ..., A( 192 ,J), J=1,...,LOT. C A ARRAY IS NOT CHANGED BY SR FFT_LONR. C C OUTPUT - LOT SETS OF COMPLEX COEFFICIENTS IN C B(1,J), B(2,J), ..., B( 63 *2,J), J=1,...,LOT. C B( 63 *2+1,J), ..., B( 192 ,J), J=1,...,LOT ARE NOT SET. C NLOT=MAX0(LOT/NCPU,LOTMIN) NLOT=MIN0(NLOT ,LOTMAX) DO 660 I=1,LOT,NLOT LOTS = MIN0(NLOT, LOT-I+1) DO 560 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 520 L=1, 192 AL(L,J-I+1) = A(L+LOFF,K) 520 CONTINUE 560 CONTINUE C C CALL CRAY FFT FOR ANALYSIS. C CALL FFT777 (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 IF(1.EQ.1) THEN C-T90 CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 ELSE C-CRA CALL RFFTMLT(AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C-T90 ENDIF CALL FFT99M (AL,WORK,TRIGS,IFAX,1,JUMP, 192 ,LOTS,-1) C DO 640 J=I,I+LOTS-1 K=(J+1)/2 LOFF=MOD(J+1,2)* 192 DO 620 L=1, 126 B(L+LOFF,K) = AL(L,J-I+1) 620 CONTINUE 640 CONTINUE 660 CONTINUE C ENDIF C RETURN END CFPP$ NOCONCUR R SUBROUTINE GFT_LONR C COMMON /COM_LONR/ITEST,JUMP,IFAX(20),TRIGS( 192 ,2) C CCC DATA ITEST/0/ CCC IF (ITEST.EQ.0) THEN ITEST=1 JUMP = 192 +3 C CALL SET777 (TRIGS, IFAX, 192 ) C-T90 IF(1.NE.1) THEN C-CRA CALL FFTFAX ( 192 ,IFAX,TRIGS) C-T90 ELSE C-T90 CALL FAX (IFAX, 192 ,3) C-T90 CALL FFTRIG (TRIGS, 192 ,3) C-T90 ENDIF CALL FAX (IFAX, 192 ,3) CALL FFTRIG (TRIGS, 192 ,3) IF (IFAX(1) .EQ. -99) PRINT 120 IF (IFAX(1) .EQ. -99) STOP 120 FORMAT (' ERROR IN GFT_LONR. 192 NOT FACTORABLE. ') PRINT 140, JUMP 140 FORMAT (' FFTFAX CALLED IN GFT_LONR. LONF = 192 ', X ' JUMP =', I5 ) CCC ENDIF C RETURN END SUBROUTINE FILTCOF(NLENP,TINC,CRITFS,CRITFL,CLANCZ,WEIGHT) C C Compute coefficients for time smoothing C C INPUT PARAMETERS C C NLENP ... Number of grid points used for time smoothing operation. C I=-NLEN .. 0 ... +NLEN where NLEN=NLENP-1 C TINC ... Time increments between the data (use any unit) C CRITFS ... Cutoff frequency, shorter side limit (in same unit as TINC C CRITFL ... Cutoff frequency, longer side limit (in same unit as TINC) C CRITFS=0. High pass fileter C CRITFL=9.E10 Low pass fileter C CLANCZ ... Lanczos filtering parameter (0. .. nofilter) C C NLEN should be chosen in such a way that 2*NLEN*TINC >= CRITFS for C high frequency filter, 2*NLEN*TINC >= CRITFL for low frequency filter C ane 2*NLEN*TINC >= CRITFL for band-pass filter. C C OPTIONAL PARAMTER C C LRESP ... Array length required for response function calculation C PARAMETER (LRESP=100) C DIMENSION WEIGHT(1) C DIMENSION RESP(LRESP) C PAI=4.*ATAN(1.) C NLEN=NLENP-1 PRINT *,' --- Time filtering coefficient calculation ---' PRINT *,'NLEN=',NLEN PRINT *,'CLANCZ=',CLANCZ C IF(CRITFS.EQ.0.) THEN IF(CRITFL.EQ.0.) THEN PRINT *,'ERROR' PRINT *,'CRITFL and CRITFS both equal zero' CALL ABORT ENDIF THETACL=(2.*PAI/CRITFL)*TINC WEIGHT(1)=1.-THETACL/PAI PRINT *,'High pass filter' PRINT *,'CRITFL=',CRITFL PRINT *,'THETACL=',THETACL LB=0 ELSEIF(CRITFL.EQ.9.E10) THEN THETACS=(2.*PAI/CRITFS)*TINC WEIGHT(1)=THETACS/PAI PRINT *,'Low pass filter' PRINT *,'CRITFS=',CRITFS PRINT *,'THETACS=',THETACS LB=1 ELSEIF(CRITFS.LT.0..OR.CRITFL.LT.0.) THEN PRINT *,'ERROR' PRINT *,'CRITFS or CRITFL < 0' CALL ABORT ELSE THETACS=(2.*PAI/CRITFS)*TINC THETACL=(2.*PAI/CRITFL)*TINC WEIGHT(1)=(THETACS-THETACL)/PAI PRINT *,'Band pass filter' PRINT *,'CRITFS=',CRITFS,' CRITFL=',CRITFL PRINT *,'THETACS,THETACL=',THETACS,THETACL LB=2 ENDIF PRINT *,' ' C C LB=0 .. High pass, LB=1 .. Low pass, LB=2 .. Band pass C C Weight calculation C DO N=1,NLEN IF(CRITFS.EQ.0.) THEN WEIGHT(N+1)=-SIN(FLOAT(N)*THETACL)/(FLOAT(N)*PAI) ELSEIF(CRITFL.EQ.9.E10) THEN WEIGHT(N+1)= SIN(FLOAT(N)*THETACS)/(FLOAT(N)*PAI) ELSE WEIGHT(N+1)=(SIN(FLOAT(N)*THETACS)-SIN(FLOAT(N)*THETACL))/ 1 (FLOAT(N)*PAI) ENDIF IF(CLANCZ.GT.0.) THEN WEIGHT(N+1)=WEIGHT(N+1)* 1 (SIN(FLOAT(N)*PAI/(FLOAT(NLEN)*CLANCZ+1.)))/ 2 ((FLOAT(N)*PAI)/(FLOAT(NLEN)*CLANCZ+1.)) ENDIF ENDDO C PRINT *,' ' PRINT *,'Unnormalized Coefficients' DO N=1,NLENP PRINT *,N-1,WEIGHT(N) ENDDO C C Normalize weights C Factor 2 for -n to n C IF(LB.EQ.1) THEN CRITIV=0. ELSEIF(LB.EQ.0) THEN CRITIV=1./(2.*TINC) ELSEIF(LB.EQ.2) THEN C CRITIV=1./((CRITFL+CRITFS)*0.5) CRITIV=(1./CRITFL+1./CRITFS)*0.5 ENDIF SSUM=WEIGHT(1) WSUM=0. DO N=1,NLEN X=COS(2.*PAI*TINC*FLOAT(N)*CRITIV) PRINT *,'X=',X SSUM=SSUM+WEIGHT(N+1)*2. WSUM=WSUM+WEIGHT(N+1)*2.*X ENDDO PRINT *,' ' PRINT *,'Sum of weights without weighting =',SSUM C C Shift central point for high pass and band pass filter C IF(LB.EQ.0.OR.LB.EQ.2) THEN WEIGHT(1)=WEIGHT(1)-SSUM ENDIF WSUM=WSUM+WEIGHT(1) C USUM=WEIGHT(1) DO N=1,NLEN USUM=USUM+WEIGHT(N+1)*2. ENDDO PRINT *,'Sum of Shifted weights =',USUM C C Normalize C WEIGHT(1)=WEIGHT(1)/WSUM TSUM=WEIGHT(1) DO N=1,NLEN WEIGHT(N+1)=WEIGHT(N+1)/WSUM TSUM=TSUM+WEIGHT(N+1)*2. ENDDO PRINT *,'Sum of weights with weighting =',WSUM PRINT *,'Sum of weights after normalization =',TSUM VSUM=WEIGHT(1) DO N=1,NLEN X=COS(2.*PAI*TINC*FLOAT(N)*CRITIV) VSUM=VSUM+WEIGHT(N+1)*2.*X ENDDO PRINT *,'Weighted sum of weights after normalization =',VSUM C C Print final coefficients C PRINT *,'Normalized and shifted Coefficients' DO N=1,NLENP PRINT *,N-1,WEIGHT(N) ENDDO C C Compute response function C DO I=1,LRESP RESP(I)=WEIGHT(1) ENDDO IF(CRITFS.EQ.0.) THEN XLEN=THETACL*5. ELSEIF(CRITFL.EQ.9.E10) THEN XLEN=THETACS*5. ELSE XLEN=THETACS*5. ENDIF IF(XLEN.GT.PAI) XLEN=PAI DO I=1,LRESP THETA=XLEN/FLOAT(LRESP-1)*FLOAT(I-1) DO N=1,NLEN RESP(I)=RESP(I)+2.*WEIGHT(N+1)*COS(FLOAT(N)*THETA) ENDDO ENDDO C PI=4.*ATAN(1.) PRINT *,' ' PRINT *,'Response function' DO I=1,LRESP FREQ=XLEN/FLOAT(LRESP-1)*FLOAT(I-1) IF(FREQ.NE.0.) THEN PERI=2*PI/FREQ*TINC ELSE PERI=9.E30 ENDIF WRITE(6,1010) I,FREQ,PERI,RESP(I) 1010 FORMAT(I3,3E14.5) ENDDO C RETURN END SUBROUTINE FILTR1(TEM,TE,Y,DIM,DI,X,ZEM,ZE,W,RM,RQ,RT,FILTA) DIMENSION 1 TE( 4033 , 28 ), DI( 4033 , 28 ), ZE( 4033 , 28 ), 1 TEM( 4033 , 28 ),DIM( 4033 , 28 ),ZEM( 4033 , 28 ), 1 Y( 4033 , 28 ), X( 4033 , 28 ), W( 4033 , 28 ), 1 RQ( 4033 , 28 ), RT( 4033 , 28 ), RM( 4033 , 28 ) FILTB = (1.-FILTA)*0.5 DO 4900 K=1, 28 DO 4900 J=1, 4032 TEM(J,K)=FILTB*TEM(J,K)+FILTA*TE(J,K) DIM(J,K)=FILTB*DIM(J,K)+FILTA*DI(J,K) ZEM(J,K)=FILTB*ZEM(J,K)+FILTA*ZE(J,K) 4900 CONTINUE DO 4901 K=1, 28 DO 4901 J=1, 4032 RM(J,K)=FILTB*RM(J,K)+FILTA*RQ(J,K) 4901 CONTINUE RETURN END SUBROUTINE FILTR2(TEM,TE,Y,DIM,DI,X,ZEM,ZE,W,RM,RQ,RT,FILTA) DIMENSION 1 TE( 4033 , 28 ), DI( 4033 , 28 ), ZE( 4033 , 28 ), 1 TEM( 4033 , 28 ),DIM( 4033 , 28 ),ZEM( 4033 , 28 ), 1 Y( 4033 , 28 ), X( 4033 , 28 ), W( 4033 , 28 ), 1 RQ( 4033 , 28 ), RT( 4033 , 28 ), RM( 4033 , 28 ) FILTB = (1.-FILTA)* 0.5 DO 4900 K=1, 28 DO 4900 J=1, 4032 TE(J,K)=Y(J,K) DI(J,K)=X(J,K) ZE(J,K)=W(J,K) TEM(J,K)=TEM(J,K)+FILTB*TE(J,K) DIM(J,K)=DIM(J,K)+FILTB*DI(J,K) ZEM(J,K)=ZEM(J,K)+FILTB*ZE(J,K) 4900 CONTINUE DO 4901 K=1, 28 DO 4901 J=1, 4032 RQ(J,K)=RT(J,K) RM(J,K)=RM(J,K)+FILTB*RQ(J,K) 4901 CONTINUE RETURN END SUBROUTINE FIXIO (FHOUR,TSEA,SMC,SHELEG,STC,TG3,ZORL,PLANTR, & CV,CVB,CVT,ALBEDO,SLMSK,F10M,CANOPY,IOFLAG,NREAD,NWRIT) DIMENSION IDATE(4) CHARACTER*8 LABEL(4) DIMENSION TSEA ( 384 , 47 ), SMC ( 384 , 47 , 2 ), & SHELEG( 384 , 47 ), STC ( 384 , 47 , 2 ), & TG3 ( 384 , 47 ), & ZORL ( 384 , 47 ), SLMSK ( 384 , 47 ), & CV ( 384 , 47 ), CVB ( 384 , 47 ), & CVT ( 384 , 47 ), PLANTR( 384 , 47 ), & F10M ( 384 , 47 ),CANOPY( 384 , 47 ), & ALBEDO( 384 , 47 ) DIMENSION WORK( 384 * 47 ) C C C IOFLAG = 0 ... READ FIXED FIELD FROM UNIT NREAD C IOFLAG = 1 ... WRITE FIXED FIELD TO UNIT NWRIT C LOLA = 384 * 47 IF(IOFLAG.EQ.0) THEN REWIND NREAD READ(NREAD) LABEL READ(NREAD) GHOUR, IDATE 99 FORMAT(1H ,'FHOUR, IDATE=',F6.2,2X,4(1X,I4)) PRINT *,'FIX FIELD READ IN FROM UNIT=',NREAD PRINT 99,FHOUR, IDATE READ(NREAD) TSEA READ(NREAD) SMC READ(NREAD) SHELEG READ(NREAD) STC READ(NREAD) TG3 READ(NREAD) ZORL READ(NREAD) CV READ(NREAD) CVB READ(NREAD) CVT READ(NREAD) ALBEDO READ(NREAD) SLMSK READ(NREAD) PLANTR READ(NREAD,ERR=5000) CANOPY C READ(NREAD,ERR=5000) F10M C CALL ROW1NS(TSEA) CALL ROW1NS(SHELEG) CALL ROW1NS(TG3) CALL ROW1NS(ZORL) CALL ROW1NS(CV) CALL ROW1NS(CVB) CALL ROW1NS(CVT) CALL ROW1NS(ALBEDO) CALL ROW1NS(PLANTR) CALL ROW1NS(SLMSK) CALL ROW1NS(CANOPY) DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = SMC(I,J,K) ENDDO ENDDO CALL ROW1NS(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I SMC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = STC(I,J,K) ENDDO ENDDO CALL ROW1NS(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I STC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO C PRINT 101,FHOUR,IDATE,LOLA 101 FORMAT(1H ,'IN FIXIO FHOUR IDATE LOLA=',F6.2,2X,4(1X,I4),2X,I5) ELSE CALL ROWSEP(TSEA) CALL ROWSEP(SHELEG) CALL ROWSEP(TG3) CALL ROWSEP(ZORL) CALL ROWSEP(CV) CALL ROWSEP(CVB) CALL ROWSEP(CVT) CALL ROWSEP(SLMSK) CALL ROWSEP(F10M) CALL ROWSEP(CANOPY) DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = SMC(I,J,K) ENDDO ENDDO CALL ROWSEP(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I SMC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = STC(I,J,K) ENDDO ENDDO CALL ROWSEP(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I STC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO C REWIND NREAD REWIND NWRIT READ(NREAD) LABEL WRITE(NWRIT) LABEL READ(NREAD) GHOUR, IDATE PRINT *,'FIX FIELD READ IN FROM UNIT=',NREAD PRINT 99,FHOUR, IDATE WRITE(NWRIT) FHOUR, IDATE READ(NREAD) WRITE(NWRIT) TSEA READ(NREAD) WRITE(NWRIT) SMC READ(NREAD) WRITE(NWRIT) SHELEG READ(NREAD) WRITE(NWRIT) STC READ(NREAD) WORK WRITE(NWRIT) WORK READ(NREAD) WRITE(NWRIT) ZORL READ(NREAD) WRITE(NWRIT) CV READ(NREAD) WRITE(NWRIT) CVB READ(NREAD) WRITE(NWRIT) CVT READ(NREAD) WORK WRITE(NWRIT) WORK READ(NREAD) WRITE(NWRIT) SLMSK READ(NREAD) WORK WRITE(NWRIT) WORK C READ(NREAD) WRITE(NWRIT) CANOPY WRITE(NWRIT) F10M C CALL ROW1NS(TSEA) CALL ROW1NS(SHELEG) CALL ROW1NS(TG3) CALL ROW1NS(ZORL) CALL ROW1NS(CV) CALL ROW1NS(CVB) CALL ROW1NS(CVT) CALL ROW1NS(SLMSK) CALL ROW1NS(F10M) CALL ROW1NS(CANOPY) DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = SMC(I,J,K) ENDDO ENDDO CALL ROW1NS(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I SMC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = STC(I,J,K) ENDDO ENDDO CALL ROW1NS(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I STC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO C 100 FORMAT(1H ,'OUT FIXIO FHOUR IDATE LOLA=',F6.2,2X,4(1X,I4),2X,I5) 103 FORMAT(1H ,'SHALOM FROM FIXIO BENCH NWRIT=',I2) PRINT 100,FHOUR,IDATE,LOLA PRINT 103,NWRIT ENDIF C RETURN 5000 PRINT *, ' ERROR IN INPUT IN FIXIO' STOP END SUBROUTINE FL2IP(FP,FM,FLN,QLN,LEVS) c c parallelize at K level. c PARAMETER (LEN0P= 62 ) PARAMETER (LEN0M= 62 ) PARAMETER (LNT= 2016 ) PARAMETER (LNT22= 4033 ) PARAMETER (JCAP= 62 ) DIMENSION FP(2,0:LEN0P,LEVS), FM(2,0:LEN0M,LEVS), . QLN(2*LNT), FLN(LNT22,LEVS) C C LOCAL SCALARS C ------------- C INTEGER N, L, K C C STATEMENT FUNCTION C ------------------ C C OFFSET(N,L) IS THE OFFSET IN WORDS C TO THE (N,L)-ELEMENT OF A LOWER C TRIANGULAR MATRIX OF COMPLEX NUMBERS C IN AN ARRAY CONTAINING THE MATRIX C PACKED IN COLUMN-MAJOR ORDER, C WHERE L AND N RANGE FROM 0 TO JCAP, C INCLUSIVE C C LOWER TRIANGULAR MATRIX OF COMPLEX NUMBERS: C C L --> C C X C N X X C X X X C | X X X X C V X X X X X C X X X X X X C C ORDER OF THE MATRIX ELEMENTS IN MEMORY: C C (0,0), (1,0), (2,0), ..., (JCAP,0), (1,1), (2,1), (3,1), ... C INTEGER OFFSET OFFSET(N,L) = (JCAP+1)*(JCAP+2) - (JCAP+1-L)*(JCAP+2-L) + 2*(N-L) C C ---------------------------------------------------------------- C COMPUTE THE COEFFICIENTS OF THE EXPANSION IN SPHERICAL HARMONICS C OF THE FIELD AT EACH LEVEL C ---------------------------------------------------------------- C CcFPP$ CNCALL C C$DOACROSS SHARE(FP,FM,FLN,QLN) C$& LOCAL(K,L,N) C DO K=1,LEVS ! MJ 5/8/1998 DO L = 0, JCAP C C COMPUTE THE EVEN (N-L) EXPANSION COEFFICIENTS FOR EACH LEVEL C ------------------------------------------------------------ C C REAL PART C DO N = L, JCAP, 2 FLN(OFFSET(N,L)+1,K) = FLN(OFFSET(N,L)+1,K) 1 + FP(1,L,K)*QLN(OFFSET(N,L)+1) END DO C C IMAGINARY PART C DO N = L, JCAP, 2 FLN(OFFSET(N,L)+2,K) = FLN(OFFSET(N,L)+2,K) 1 + FP(2,L,K)*QLN(OFFSET(N,L)+2) END DO C C COMPUTE THE ODD (N-L) EXPANSION COEFFICIENTS FOR EACH LEVEL C ----------------------------------------------------------- C C REAL PART C DO N = L+1, JCAP, 2 FLN(OFFSET(N,L)+1,K) = FLN(OFFSET(N,L)+1,K) 1 + FM(1,L,K)*QLN(OFFSET(N,L)+1) END DO C C IMAGINARY PART C DO N = L+1, JCAP, 2 FLN(OFFSET(N,L)+2,K) = FLN(OFFSET(N,L)+2,K) 1 + FM(2,L,K)*QLN(OFFSET(N,L)+2) END DO C ENDDO ENDDO !MJ 5/8/1998 C RETURN END CFPP$ NOCONCUR R SUBROUTINE FLPFLM2(FLP,FLM,ANL,lot) C................................................................. C FOR LOOPA C DIMENSION X FLP(2, 63 ,lot),FLM(2, 63 ,lot), X ANL( 386 ,lot) C C................................................................. C DO K=1,lot DO LL=1, 63 C DO N.HEMI FLP(1,LL,K)=ANL(2*(LL-1)+1,K)+ 1 ANL(2*(LL-1)+1+ 192 ,K) FLP(2,LL,K)=ANL(2*(LL-1)+2,K)+ 1 ANL(2*(LL-1)+2+ 192 ,K) C C DO S.HEMI C FLM(1,LL,K)=ANL(2*(LL-1)+1,K)- 1 ANL(2*(LL-1)+1+ 192 ,K) FLM(2,LL,K)=ANL(2*(LL-1)+2,K)- 1 ANL(2*(LL-1)+2+ 192 ,K) ENDDO ENDDO C................................................................. RETURN END CFPP$ NOCONCUR R SUBROUTINE FLPFLM(FLP,FLM,ANL) C................................................................. C FOR LOOPA C DIMENSION X FLP(2, 63 , 113 ),FLM(2, 63 , 113 ), X ANL( 386 , 113 ) C C................................................................. C C DO K=1,4* 28 +1 DO K=1, 113 DO LL=1, 63 C DO N.HEMI FLP(1,LL,K)=ANL(2*(LL-1)+1,K)+ 1 ANL(2*(LL-1)+1+ 192 ,K) FLP(2,LL,K)=ANL(2*(LL-1)+2,K)+ 1 ANL(2*(LL-1)+2+ 192 ,K) C C DO S.HEMI C FLM(1,LL,K)=ANL(2*(LL-1)+1,K)- 1 ANL(2*(LL-1)+1+ 192 ,K) FLM(2,LL,K)=ANL(2*(LL-1)+2,K)- 1 ANL(2*(LL-1)+2+ 192 ,K) ENDDO ENDDO C................................................................. RETURN END CFPP$ NOCONCUR R SUBROUTINE FBPFBM(FLP,FLM,ANL) C................................................................. C FOR LOOPB C DIMENSION X FLP(2, 63 , 112 ),FLM(2, 63 , 112 ), X ANL( 386 , 224 ) C C................................................................. C DO K=1, 112 DO LL=1, 63 C DO N.HEMI FLP(1,LL,K)=ANL(2*(LL-1)+1,K)+ 1 ANL(2*(LL-1)+1+ 192 ,K) FLP(2,LL,K)=ANL(2*(LL-1)+2,K)+ 1 ANL(2*(LL-1)+2+ 192 ,K) C C DO S.HEMI C FLM(1,LL,K)=ANL(2*(LL-1)+1,K)- 1 ANL(2*(LL-1)+1+ 192 ,K) FLM(2,LL,K)=ANL(2*(LL-1)+2,K)- 1 ANL(2*(LL-1)+2+ 192 ,K) ENDDO ENDDO C................................................................. RETURN END C----------------------------------------------------------------------- CFPP$ EXPAND(FPVSX) SUBROUTINE GPVS C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GPVS COMPUTE SATURATION VAPOR PRESSURE TABLE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE TABLE AS A FUNCTION OF C TEMPERATURE FOR THE TABLE LOOKUP FUNCTION FPVS. C EXACT SATURATION VAPOR PRESSURES ARE CALCULATED IN SUBPROGRAM FPVSX. C THE CURRENT IMPLEMENTATION COMPUTES A TABLE WITH A LENGTH C OF 7501 FOR TEMPERATURES RANGING FROM 180. TO 330. KELVIN. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL C 94-12-30 IREDELL EXPAND TABLE C C USAGE: CALL GPVS C C SUBPROGRAMS CALLED: C (FPVSX) - INLINABLE FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE C C COMMON BLOCKS: C COMPVS - SCALING PARAMETERS AND TABLE FOR FUNCTION FPVS. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=7501) DIMENSION TBPVS(NX) COMMON/COMPVS/ C1XPVS,C2XPVS,TBPVS C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN=180.0 XMAX=330.0 XINC=(XMAX-XMIN)/(NX-1) C1XPVS=1.-XMIN/XINC C2XPVS=1./XINC DO JX=1,NX X=XMIN+(JX-1)*XINC T=X TBPVS(JX)=FPVSX(T) ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FPVS(T) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FPVS COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE FROM THE TEMPERATURE. C A LINEAR INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GPVS. SEE DOCUMENTATION FOR FPVSX FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. C THE INTERPOLATION ACCURACY IS ALMOST 6 DECIMAL PLACES. C ON THE CRAY, FPVS IS ABOUT 4 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXPAND TABLE C C USAGE: PVS=FPVS(T) C C INPUT ARGUMENT LIST: C T - REAL TEMPERATURE IN KELVIN C C OUTPUT ARGUMENT LIST: C FPVS - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB) C C COMMON BLOCKS: C COMPVS - SCALING PARAMETERS AND TABLE COMPUTED IN GPVS. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=7501) DIMENSION TBPVS(NX) COMMON/COMPVS/ C1XPVS,C2XPVS,TBPVS C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(MAX(C1XPVS+C2XPVS*T,1.),FLOAT(NX)) JX=MIN(XJ,NX-1.) FPVS=TBPVS(JX)+(XJ-JX)*(TBPVS(JX+1)-TBPVS(JX)) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FPVSQ(T) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FPVSQ COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE FROM THE TEMPERATURE. C A QUADRATIC INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GPVS. SEE DOCUMENTATION FOR FPVSX FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. C THE INTERPOLATION ACCURACY IS ALMOST 9 DECIMAL PLACES. C ON THE CRAY, FPVSQ IS ABOUT 3 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL QUADRATIC INTERPOLATION C C USAGE: PVS=FPVSQ(T) C C INPUT ARGUMENT LIST: C T - REAL TEMPERATURE IN KELVIN C C OUTPUT ARGUMENT LIST: C FPVSQ - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB) C C COMMON BLOCKS: C COMPVS - SCALING PARAMETERS AND TABLE COMPUTED IN GPVS. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=7501) DIMENSION TBPVS(NX) COMMON/COMPVS/ C1XPVS,C2XPVS,TBPVS C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(MAX(C1XPVS+C2XPVS*T,1.),FLOAT(NX)) JX=MIN(MAX(NINT(XJ),2),NX-1) DXJ=XJ-JX FJ1=TBPVS(JX-1) FJ2=TBPVS(JX) FJ3=TBPVS(JX+1) FPVSQ=(((FJ3+FJ1)/2-FJ2)*DXJ+(FJ3-FJ1)/2)*DXJ+FJ2 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FPVSX(T) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FPVSX COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: EXACTLY COMPUTE SATURATION VAPOR PRESSURE FROM TEMPERATURE. C THE WATER MODEL ASSUMES A PERFECT GAS, CONSTANT SPECIFIC HEATS C FOR GAS AND LIQUID, AND NEGLECTS THE VOLUME OF THE LIQUID. C THE MODEL DOES ACCOUNT FOR THE VARIATION OF THE LATENT HEAT C OF CONDENSATION WITH TEMPERATURE. THE ICE OPTION IS NOT INCLUDED. C THE CLAUSIUS-CLAPEYRON EQUATION IS INTEGRATED FROM THE TRIPLE POINT C TO GET THE FORMULA C PVS=PSATK*(TR**XA)*EXP(XB*(1.-TR)) C WHERE TR IS TTP/T AND OTHER VALUES ARE PHYSICAL CONSTANTS C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXACT COMPUTATION C C USAGE: PVS=FPVSX(T) C C INPUT ARGUMENT LIST: C T - REAL TEMPERATURE IN KELVIN C C OUTPUT ARGUMENT LIST: C FPVSX - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB) C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ,RV= 4.6150E+2 , & TTP= 2.7316E+2 ,HVAP= 2.5000E+6 ,PSAT= 6.1078E+2 , & CLIQ= 4.1855E+3 ,CVAP= 1.8460E+3 ) PARAMETER(PSATK=PSAT*1.E-3) PARAMETER(DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - TR=TTP/T FPVSX=PSATK*(TR**XA)*EXP(XB*(1.-TR)) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ EXPAND(FTDPXG) SUBROUTINE GTDP C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GTDP COMPUTE DEWPOINT TEMPERATURE TABLE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE DEWPOINT TEMPERATURE TABLE AS A FUNCTION OF C VAPOR PRESSURE FOR INLINABLE FUNCTION FTDP. C EXACT DEWPOINT TEMPERATURES ARE CALCULATED IN SUBPROGRAM FTDPXG. C THE CURRENT IMPLEMENTATION COMPUTES A TABLE WITH A LENGTH C OF 5001 FOR VAPOR PRESSURES RANGING FROM 0.001 TO 10.001 KILOPASCALS C GIVING A DEWPOINT TEMPERATURE RANGE OF 208.0 TO 319.0 KELVIN. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL C 94-12-30 IREDELL EXPAND TABLE C C USAGE: CALL GTDP C C SUBPROGRAMS CALLED: C (FTDPXG) - INLINABLE FUNCTION TO COMPUTE DEWPOINT TEMPERATURE C C COMMON BLOCKS: C COMTDP - SCALING PARAMETERS AND TABLE FOR FUNCTION FTDP. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=5001) DIMENSION TBTDP(NX) COMMON/COMTDP/ C1XTDP,C2XTDP,TBTDP C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN= 0.001 XMAX=10.001 XINC=(XMAX-XMIN)/(NX-1) C1XTDP=1.-XMIN/XINC C2XTDP=1./XINC T=208.0 DO JX=1,NX X=XMIN+(JX-1)*XINC PV=X T=FTDPXG(T,PV) TBTDP(JX)=T ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTDP(PV) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTDP COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE DEWPOINT TEMPERATURE FROM VAPOR PRESSURE. C A LINEAR INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GTDP. SEE DOCUMENTATION FOR FTDPXG FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. C THE INTERPOLATION ACCURACY IS BETTER THAN 0.0005 KELVIN C FOR DEWPOINT TEMPERATURES GREATER THAN 250 KELVIN, C BUT DECREASES TO 0.02 KELVIN FOR A DEWPOINT AROUND 230 KELVIN. C ON THE CRAY, FTDP IS ABOUT 75 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXPAND TABLE C C USAGE: TDP=FTDP(PV) C C INPUT ARGUMENT LIST: C PV - REAL VAPOR PRESSURE IN KILOPASCALS (CB) C C OUTPUT ARGUMENT LIST: C FTDP - REAL DEWPOINT TEMPERATURE IN KELVIN C C COMMON BLOCKS: C COMTDP - SCALING PARAMETERS AND TABLE COMPUTED IN GTDP. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=5001) DIMENSION TBTDP(NX) COMMON/COMTDP/ C1XTDP,C2XTDP,TBTDP C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(MAX(C1XTDP+C2XTDP*PV,1.),FLOAT(NX)) JX=MIN(XJ,NX-1.) FTDP=TBTDP(JX)+(XJ-JX)*(TBTDP(JX+1)-TBTDP(JX)) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTDPQ(PV) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTDPQ COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE DEWPOINT TEMPERATURE FROM VAPOR PRESSURE. C A QUADRATIC INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GTDP. SEE DOCUMENTATION FOR FTDPXG FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. C THE INTERPOLATION ACCURACY IS BETTER THAN 0.00001 KELVIN C FOR DEWPOINT TEMPERATURES GREATER THAN 250 KELVIN, C BUT DECREASES TO 0.002 KELVIN FOR A DEWPOINT AROUND 230 KELVIN. C ON THE CRAY, FTDPQ IS ABOUT 60 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL QUADRATIC INTERPOLATION C C USAGE: TDP=FTDPQ(PV) C C INPUT ARGUMENT LIST: C PV - REAL VAPOR PRESSURE IN KILOPASCALS (CB) C C OUTPUT ARGUMENT LIST: C FTDPQ - REAL DEWPOINT TEMPERATURE IN KELVIN C C COMMON BLOCKS: C COMTDP - SCALING PARAMETERS AND TABLE COMPUTED IN GTDP. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=5001) DIMENSION TBTDP(NX) COMMON/COMTDP/ C1XTDP,C2XTDP,TBTDP C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(MAX(C1XTDP+C2XTDP*PV,1.),FLOAT(NX)) JX=MIN(MAX(NINT(XJ),2),NX-1) DXJ=XJ-JX FJ1=TBTDP(JX-1) FJ2=TBTDP(JX) FJ3=TBTDP(JX+1) FTDPQ=(((FJ3+FJ1)/2-FJ2)*DXJ+(FJ3-FJ1)/2)*DXJ+FJ2 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R CFPP$ EXPAND(FTDP,FTDPXG) FUNCTION FTDPX(PV) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTDPX COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: EXACTLY COMPUTE DEWPOINT TEMPERATURE FROM VAPOR PRESSURE. C AN APPROXIMATE DEWPOINT TEMPERATURE FOR FUNCTION FTDPXG C IS OBTAINED USING FTDP SO GTDP MUST BE ALREADY CALLED. C SEE DOCUMENTATION FOR FTDPXG FOR DETAILS. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXACT COMPUTATION C C USAGE: TDP=FTDPX(PV) C C INPUT ARGUMENT LIST: C PV - REAL VAPOR PRESSURE IN KILOPASCALS (CB) C C OUTPUT ARGUMENT LIST: C FTDPX - REAL DEWPOINT TEMPERATURE IN KELVIN C C SUBPROGRAMS CALLED: C (FTDP) - INLINABLE FUNCTION TO COMPUTE DEWPOINT TEMPERATURE C (FTDPXG) - INLINABLE FUNCTION TO COMPUTE DEWPOINT TEMPERATURE C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - TG=FTDP(PV) FTDPX=FTDPXG(TG,PV) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTDPXG(TG,PV) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTDPXG COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: EXACTLY COMPUTE DEWPOINT TEMPERATURE FROM VAPOR PRESSURE. C A GUESS DEWPOINT TEMPERATURE MUST BE PROVIDED. C THE WATER MODEL ASSUMES A PERFECT GAS, CONSTANT SPECIFIC HEATS C FOR GAS AND LIQUID, AND NEGLECTS THE VOLUME OF THE LIQUID. C THE MODEL DOES ACCOUNT FOR THE VARIATION OF THE LATENT HEAT C OF CONDENSATION WITH TEMPERATURE. THE ICE OPTION IS NOT INCLUDED. C THE CLAUSIUS-CLAPEYRON EQUATION IS INTEGRATED FROM THE TRIPLE POINT C TO GET THE FORMULA C PVS=PSATK*(TR**XA)*EXP(XB*(1.-TR)) C WHERE TR IS TTP/T AND OTHER VALUES ARE PHYSICAL CONSTANTS C THE FORMULA IS INVERTED BY ITERATING NEWTONIAN APPROXIMATIONS C FOR EACH PVS UNTIL T IS FOUND TO WITHIN 1.E-6 KELVIN. C THIS FUNCTION CAN BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXACT COMPUTATION C C USAGE: TDP=FTDPXG(TG,PV) C C INPUT ARGUMENT LIST: C TG - REAL GUESS DEWPOINT TEMPERATURE IN KELVIN C PV - REAL VAPOR PRESSURE IN KILOPASCALS (CB) C C OUTPUT ARGUMENT LIST: C FTDPXG - REAL DEWPOINT TEMPERATURE IN KELVIN C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ,RV= 4.6150E+2 , & TTP= 2.7316E+2 ,HVAP= 2.5000E+6 ,PSAT= 6.1078E+2 , & CLIQ= 4.1855E+3 ,CVAP= 1.8460E+3 ) PARAMETER(PSATK=PSAT*1.E-3) PARAMETER(DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)) PARAMETER(TERRM=1.E-6) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - T=TG TR=TTP/T PVT=PSATK*(TR**XA)*EXP(XB*(1.-TR)) EL=HVAP+DLDT*(T-TTP) DPVT=EL*PVT/(RV*T**2) TERR=(PVT-PV)/DPVT T=T-TERR DOWHILE(ABS(TERR).GT.TERRM) TR=TTP/T PVT=PSATK*(TR**XA)*EXP(XB*(1.-TR)) EL=HVAP+DLDT*(T-TTP) DPVT=EL*PVT/(RV*T**2) TERR=(PVT-PV)/DPVT T=T-TERR ENDDO FTDPXG=T C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ EXPAND(FTHEX) SUBROUTINE GTHE C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GTHE COMPUTE EQUIVALENT POTENTIAL TEMPERATURE TABLE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE EQUIVALENT POTENTIAL TEMPERATURE TABLE C AS A FUNCTION OF LCL TEMPERATURE AND PRESSURE OVER 100 KPA C TO THE KAPPA POWER FOR FUNCTION FTHE. C EQUIVALENT POTENTIAL TEMPERATURES ARE CALCULATED IN SUBPROGRAM FTHEX C THE CURRENT IMPLEMENTATION COMPUTES A TABLE WITH A FIRST DIMENSION C OF 241 FOR TEMPERATURES RANGING FROM 183.16 TO 303.16 KELVIN C AND A SECOND DIMENSION OF 151 FOR PRESSURE OVER 100 KPA C TO THE KAPPA POWER RANGING FROM 0.04**ROCP TO 1.10**ROCP. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL C 94-12-30 IREDELL EXPAND TABLE C C USAGE: CALL GTHE C C SUBPROGRAMS CALLED: C (FTHEX) - INLINABLE FUNCTION TO COMPUTE EQUIV. POT. TEMPERATURE C C COMMON BLOCKS: C COMTHE - SCALING PARAMETERS AND TABLE FOR FUNCTION FTHE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ,TTP= 2.7316E+2 ) PARAMETER(ROCP=RD/CP) PARAMETER(NX=241,NY=151) DIMENSION TBTHE(NX,NY) COMMON/COMTHE/ C1XTHE,C2XTHE,C1YTHE,C2YTHE,TBTHE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN=TTP-90. XMAX=TTP+30. XINC=(XMAX-XMIN)/(NX-1) C1XTHE=1.-XMIN/XINC C2XTHE=1./XINC YMIN=0.04**ROCP CHMHJ CMK YMIN=0.05**ROCP YMAX=1.10**ROCP YINC=(YMAX-YMIN)/(NY-1) C1YTHE=1.-YMIN/YINC C2YTHE=1./YINC DO JY=1,NY Y=YMIN+(JY-1)*YINC PK=Y DO JX=1,NX X=XMIN+(JX-1)*XINC T=X TBTHE(JX,JY)=FTHEX(T,PK) ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTHE(T,PK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTHE COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE EQUIVALENT POTENTIAL TEMPERATURE AT THE LCL C FROM TEMPERATURE AND PRESSURE OVER 100 KPA TO THE KAPPA POWER. C A BILINEAR INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GTHE. SEE DOCUMENTATION FOR FTHEX FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA, C EXCEPT ZERO IS RETURNED FOR TOO COLD OR HIGH LCLS. C THE INTERPOLATION ACCURACY IS BETTER THAN 0.01 KELVIN. C ON THE CRAY, FTHE IS ALMOST 6 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXPAND TABLE C C USAGE: THE=FTHE(PV) C C INPUT ARGUMENT LIST: C T - REAL LCL TEMPERATURE IN KELVIN C PK - REAL LCL PRESSURE OVER 100 KPA TO THE KAPPA POWER C C OUTPUT ARGUMENT LIST: C FTHE - REAL EQUIVALENT POTENTIAL TEMPERATURE IN KELVIN C C COMMON BLOCKS: C COMTHE - SCALING PARAMETERS AND TABLE COMPUTED IN GTHE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=241,NY=151) DIMENSION TBTHE(NX,NY) COMMON/COMTHE/ C1XTHE,C2XTHE,C1YTHE,C2YTHE,TBTHE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(C1XTHE+C2XTHE*T,FLOAT(NX)) YJ=MIN(C1YTHE+C2YTHE*PK,FLOAT(NY)) IF(XJ.GE.1..AND.YJ.GE.1.) THEN JX=MIN(XJ,NX-1.) JY=MIN(YJ,NY-1.) FTX1=TBTHE(JX,JY)+(XJ-JX)*(TBTHE(JX+1,JY)-TBTHE(JX,JY)) FTX2=TBTHE(JX,JY+1)+(XJ-JX)*(TBTHE(JX+1,JY+1)-TBTHE(JX,JY+1)) FTHE=FTX1+(YJ-JY)*(FTX2-FTX1) ELSE FTHE=0. ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTHEQ(T,PK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTHEQ COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE EQUIVALENT POTENTIAL TEMPERATURE AT THE LCL C FROM TEMPERATURE AND PRESSURE OVER 100 KPA TO THE KAPPA POWER. C A BIQUADRATIC INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GTHE. SEE DOCUMENTATION FOR FTHEX FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA, C EXCEPT ZERO IS RETURNED FOR TOO COLD OR HIGH LCLS. C THE INTERPOLATION ACCURACY IS BETTER THAN 0.0002 KELVIN. C ON THE CRAY, FTHEQ IS ALMOST 3 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL QUADRATIC INTERPOLATION C C USAGE: THE=FTHEQ(PV) C C INPUT ARGUMENT LIST: C T - REAL LCL TEMPERATURE IN KELVIN C PK - REAL LCL PRESSURE OVER 100 KPA TO THE KAPPA POWER C C OUTPUT ARGUMENT LIST: C FTHEQ - REAL EQUIVALENT POTENTIAL TEMPERATURE IN KELVIN C C COMMON BLOCKS: C COMTHE - SCALING PARAMETERS AND TABLE COMPUTED IN GTHE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=241,NY=151) DIMENSION TBTHE(NX,NY) COMMON/COMTHE/ C1XTHE,C2XTHE,C1YTHE,C2YTHE,TBTHE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(C1XTHE+C2XTHE*T,FLOAT(NX)) YJ=MIN(C1YTHE+C2YTHE*PK,FLOAT(NY)) IF(XJ.GE.1..AND.YJ.GE.1.) THEN JX=MIN(MAX(NINT(XJ),2),NX-1) JY=MIN(MAX(NINT(YJ),2),NY-1) DXJ=XJ-JX DYJ=YJ-JY FT11=TBTHE(JX-1,JY-1) FT12=TBTHE(JX-1,JY) FT13=TBTHE(JX-1,JY+1) FT21=TBTHE(JX,JY-1) FT22=TBTHE(JX,JY) FT23=TBTHE(JX,JY+1) FT31=TBTHE(JX+1,JY-1) FT32=TBTHE(JX+1,JY) FT33=TBTHE(JX+1,JY+1) FTX1=(((FT31+FT11)/2-FT21)*DXJ+(FT31-FT11)/2)*DXJ+FT21 FTX2=(((FT32+FT12)/2-FT22)*DXJ+(FT32-FT12)/2)*DXJ+FT22 FTX3=(((FT33+FT13)/2-FT23)*DXJ+(FT33-FT13)/2)*DXJ+FT23 FTHEQ=(((FTX3+FTX1)/2-FTX2)*DYJ+(FTX3-FTX1)/2)*DYJ+FTX2 ELSE FTHEQ=0. ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTHEX(T,PK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTHEX COMPUTE SATURATION VAPOR PRESSURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: EXACTLY COMPUTE EQUIVALENT POTENTIAL TEMPERATURE AT THE LCL C FROM TEMPERATURE AND PRESSURE OVER 100 KPA TO THE KAPPA POWER. C EQUIVALENT POTENTIAL TEMPERATURE IS CONSTANT FOR A SATURATED PARCEL C RISING ADIABATICALLY UP A MOIST ADIABAT WHEN THE HEAT AND MASS C OF THE CONDENSED WATER ARE NEGLECTED. THE FORMULA FOR C EQUIVALENT POTENTIAL TEMPERATURE (DERIVED IN HOLTON) IS C THE=T*(PD**(-ROCP))*EXP(EL*EPS*PV/(CP*T*PD)) C WHERE T IS THE TEMPERATURE, PV IS THE SATURATED VAPOR PRESSURE, C PD IS THE DRY PRESSURE P-PV, EL IS THE TEMPERATURE DEPENDENT C LATENT HEAT OF CONDENSATION HVAP+DLDT*(T-TTP), AND OTHER VALUES C ARE PHYSICAL CONSTANTS DEFINED IN PARAMETER STATEMENTS IN THE CODE. C ZERO IS RETURNED IF THE INPUT VALUES MAKE SATURATION IMPOSSIBLE. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXACT COMPUTATION C C USAGE: THE=FTHEX(T,PK) C C INPUT ARGUMENT LIST: C T - REAL LCL TEMPERATURE IN KELVIN C PK - REAL LCL PRESSURE OVER 100 KPA TO THE KAPPA POWER C C OUTPUT ARGUMENT LIST: C FTHEX - REAL EQUIVALENT POTENTIAL TEMPERATURE IN KELVIN C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ,RV= 4.6150E+2 , & TTP= 2.7316E+2 ,HVAP= 2.5000E+6 ,PSAT= 6.1078E+2 , & CLIQ= 4.1855E+3 ,CVAP= 1.8460E+3 ) PARAMETER(PSATK=PSAT*1.E-3) PARAMETER(ROCP=RD/CP,CPOR=CP/RD,PSATB=PSATK*1.E-2,EPS=RD/RV, & DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - P=PK**CPOR TR=TTP/T PV=PSATB*(TR**XA)*EXP(XB*(1.-TR)) PD=P-PV IF(PD.GT.0.) THEN EL=HVAP+DLDT*(T-TTP) C EXPO=EL*EPS*PV/(CP*T*PD) C FTHEX=T*PD**(-ROCP)*EXP(EXPO) EXPO=EL*EPS*PV/(CP*T*PD) EXPO = MIN(EXPO,100.0) FTHEX=T*PD**(-ROCP)*EXP(EXPO) ELSE FTHEX=0. ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ EXPAND(FTMAXG) SUBROUTINE GTMA C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GTMA COMPUTE MOIST ADIABAT TABLES C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE TEMPERATURE AND SPECIFIC HUMIDITY TABLES C AS A FUNCTION OF EQUIVALENT POTENTIAL TEMPERATURE AND C PRESSURE OVER 100 KPA TO THE KAPPA POWER FOR FUNCTION FTMA. C EXACT PARCEL TEMPERATURES ARE CALCULATED IN SUBPROGRAM FTMAXG. C THE CURRENT IMPLEMENTATION COMPUTES A TABLE WITH A FIRST DIMENSION C OF 151 FOR EQUIVALENT POTENTIAL TEMPERATURES RANGING FROM 200 TO 500 C KELVIN AND A SECOND DIMENSION OF 121 FOR PRESSURE OVER 100 KPA C TO THE KAPPA POWER RANGING FROM 0.01**ROCP TO 1.10**ROCP. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL C 94-12-30 IREDELL EXPAND TABLE C C USAGE: CALL GTMA C C SUBPROGRAMS CALLED: C (FTMAXG) - INLINABLE FUNCTION TO COMPUTE PARCEL TEMPERATURE C C COMMON BLOCKS: C COMMA - SCALING PARAMETERS AND TABLE FOR FUNCTION FTMA. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ) PARAMETER(ROCP=RD/CP) PARAMETER(NX=151,NY=121) DIMENSION TBTMA(NX,NY),TBQMA(NX,NY) COMMON/COMMA/ C1XMA,C2XMA,C1YMA,C2YMA,TBTMA,TBQMA C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN=200. XMAX=500. XINC=(XMAX-XMIN)/(NX-1) C1XMA=1.-XMIN/XINC C2XMA=1./XINC YMIN=0.01**ROCP YMAX=1.10**ROCP YINC=(YMAX-YMIN)/(NY-1) C1YMA=1.-YMIN/YINC C2YMA=1./YINC DO JY=1,NY Y=YMIN+(JY-1)*YINC PK=Y T=XMIN*Y DO JX=1,NX X=XMIN+(JX-1)*XINC THE=X T=FTMAXG(T,THE,PK,Q) TBTMA(JX,JY)=T TBQMA(JX,JY)=Q ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTMA(THE,PK,QMA) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTMA COMPUTE MOIST ADIABAT TEMPERATURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE TEMPERATURE AND SPECIFIC HUMIDITY OF A PARCEL C LIFTED UP A MOIST ADIABAT FROM EQUIVALENT POTENTIAL TEMPERATURE C AT THE LCL AND PRESSURE OVER 100 KPA TO THE KAPPA POWER. C BILINEAR INTERPOLATIONS ARE DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GTMA. SEE DOCUMENTATION FOR FTMAXG FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. C THE INTERPOLATION ACCURACY IS BETTER THAN 0.01 KELVIN C AND 5.E-6 KG/KG FOR TEMPERATURE AND HUMIDITY, RESPECTIVELY. C ON THE CRAY, FTMA IS ABOUT 35 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXPAND TABLE C C USAGE: TMA=FTMA(THE,PK,QMA) C C INPUT ARGUMENT LIST: C THE - REAL EQUIVALENT POTENTIAL TEMPERATURE IN KELVIN C PK - REAL PRESSURE OVER 100 KPA TO THE KAPPA POWER C C OUTPUT ARGUMENT LIST: C FTMA - REAL PARCEL TEMPERATURE IN KELVIN C QMA - REAL PARCEL SPECIFIC HUMIDITY IN KG/KG C C COMMON BLOCKS: C COMMA - SCALING PARAMETERS AND TABLE COMPUTED IN GTMA. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=151,NY=121) DIMENSION TBTMA(NX,NY),TBQMA(NX,NY) COMMON/COMMA/ C1XMA,C2XMA,C1YMA,C2YMA,TBTMA,TBQMA C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(MAX(C1XMA+C2XMA*THE,1.),FLOAT(NX)) YJ=MIN(MAX(C1YMA+C2YMA*PK,1.),FLOAT(NY)) JX=MIN(XJ,NX-1.) JY=MIN(YJ,NY-1.) FTX1=TBTMA(JX,JY)+(XJ-JX)*(TBTMA(JX+1,JY)-TBTMA(JX,JY)) FTX2=TBTMA(JX,JY+1)+(XJ-JX)*(TBTMA(JX+1,JY+1)-TBTMA(JX,JY+1)) FTMA=FTX1+(YJ-JY)*(FTX2-FTX1) QX1=TBQMA(JX,JY)+(XJ-JX)*(TBQMA(JX+1,JY)-TBQMA(JX,JY)) QX2=TBQMA(JX,JY+1)+(XJ-JX)*(TBQMA(JX+1,JY+1)-TBQMA(JX,JY+1)) QMA=QX1+(YJ-JY)*(QX2-QX1) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTMAQ(THE,PK,QMA) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTMAQ COMPUTE MOIST ADIABAT TEMPERATURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: COMPUTE TEMPERATURE AND SPECIFIC HUMIDITY OF A PARCEL C LIFTED UP A MOIST ADIABAT FROM EQUIVALENT POTENTIAL TEMPERATURE C AT THE LCL AND PRESSURE OVER 100 KPA TO THE KAPPA POWER. C BIQUADRATIC INTERPOLATIONS ARE DONE BETWEEN VALUES IN A LOOKUP TABLE C COMPUTED IN GTMA. SEE DOCUMENTATION FOR FTMAXG FOR DETAILS. C INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. C THE INTERPOLATION ACCURACY IS BETTER THAN 0.0005 KELVIN C AND 1.E-7 KG/KG FOR TEMPERATURE AND HUMIDITY, RESPECTIVELY. C ON THE CRAY, FTMAQ IS ABOUT 25 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL QUADRATIC INTERPOLATION C C USAGE: TMA=FTMAQ(THE,PK,QMA) C C INPUT ARGUMENT LIST: C THE - REAL EQUIVALENT POTENTIAL TEMPERATURE IN KELVIN C PK - REAL PRESSURE OVER 100 KPA TO THE KAPPA POWER C C OUTPUT ARGUMENT LIST: C FTMAQ - REAL PARCEL TEMPERATURE IN KELVIN C QMA - REAL PARCEL SPECIFIC HUMIDITY IN KG/KG C C COMMON BLOCKS: C COMMA - SCALING PARAMETERS AND TABLE COMPUTED IN GTMA. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(NX=151,NY=121) DIMENSION TBTMA(NX,NY),TBQMA(NX,NY) COMMON/COMMA/ C1XMA,C2XMA,C1YMA,C2YMA,TBTMA,TBQMA C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XJ=MIN(MAX(C1XMA+C2XMA*THE,1.),FLOAT(NX)) YJ=MIN(MAX(C1YMA+C2YMA*PK,1.),FLOAT(NY)) JX=MIN(MAX(NINT(XJ),2),NX-1) JY=MIN(MAX(NINT(YJ),2),NY-1) DXJ=XJ-JX DYJ=YJ-JY FT11=TBTMA(JX-1,JY-1) FT12=TBTMA(JX-1,JY) FT13=TBTMA(JX-1,JY+1) FT21=TBTMA(JX,JY-1) FT22=TBTMA(JX,JY) FT23=TBTMA(JX,JY+1) FT31=TBTMA(JX+1,JY-1) FT32=TBTMA(JX+1,JY) FT33=TBTMA(JX+1,JY+1) FTX1=(((FT31+FT11)/2-FT21)*DXJ+(FT31-FT11)/2)*DXJ+FT21 FTX2=(((FT32+FT12)/2-FT22)*DXJ+(FT32-FT12)/2)*DXJ+FT22 FTX3=(((FT33+FT13)/2-FT23)*DXJ+(FT33-FT13)/2)*DXJ+FT23 FTMAQ=(((FTX3+FTX1)/2-FTX2)*DYJ+(FTX3-FTX1)/2)*DYJ+FTX2 Q11=TBQMA(JX-1,JY-1) Q12=TBQMA(JX-1,JY) Q13=TBQMA(JX-1,JY+1) Q21=TBQMA(JX,JY-1) Q22=TBQMA(JX,JY) Q23=TBQMA(JX,JY+1) Q31=TBQMA(JX+1,JY-1) Q32=TBQMA(JX+1,JY) Q33=TBQMA(JX+1,JY+1) QX1=(((Q31+Q11)/2-Q21)*DXJ+(Q31-Q11)/2)*DXJ+Q21 QX2=(((Q32+Q12)/2-Q22)*DXJ+(Q32-Q12)/2)*DXJ+Q22 QX3=(((Q33+Q13)/2-Q23)*DXJ+(Q33-Q13)/2)*DXJ+Q23 QMA=(((QX3+QX1)/2-QX2)*DYJ+(QX3-QX1)/2)*DYJ+QX2 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R CFPP$ EXPAND(FTMA,FTMAXG) FUNCTION FTMAX(THE,PK,QMA) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTMAX COMPUTE MOIST ADIABAT TEMPERATURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: EXACTLY COMPUTE TEMPERATURE AND HUMIDITY OF A PARCEL C LIFTED UP A MOIST ADIABAT FROM EQUIVALENT POTENTIAL TEMPERATURE C AT THE LCL AND PRESSURE OVER 100 KPA TO THE KAPPA POWER. C AN APPROXIMATE PARCEL TEMPERATURE FOR FUNCTION FTMAXG C IS OBTAINED USING FTMA SO GTMA MUST BE ALREADY CALLED. C SEE DOCUMENTATION FOR FTMAXG FOR DETAILS. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXACT COMPUTATION C C USAGE: TMA=FTMAX(THE,PK,QMA) C C INPUT ARGUMENT LIST: C THE - REAL EQUIVALENT POTENTIAL TEMPERATURE IN KELVIN C PK - REAL PRESSURE OVER 100 KPA TO THE KAPPA POWER C C OUTPUT ARGUMENT LIST: C FTMAX - REAL PARCEL TEMPERATURE IN KELVIN C QMA - REAL PARCEL SPECIFIC HUMIDITY IN KG/KG C C SUBPROGRAMS CALLED: C (FTMA) - INLINABLE FUNCTION TO COMPUTE PARCEL TEMPERATURE C (FTMAXG) - INLINABLE FUNCTION TO COMPUTE PARCEL TEMPERATURE C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - TG=FTMA(THE,PK,QG) FTMAX=FTMAXG(TG,THE,PK,QMA) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTMAXG(TG,THE,PK,QMA) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTMAXG COMPUTE MOIST ADIABAT TEMPERATURE C AUTHOR: N PHILLIPS W/NMC2X2 DATE: 30 DEC 82 C C ABSTRACT: EXACTLY COMPUTE TEMPERATURE AND HUMIDITY OF A PARCEL C LIFTED UP A MOIST ADIABAT FROM EQUIVALENT POTENTIAL TEMPERATURE C AT THE LCL AND PRESSURE OVER 100 KPA TO THE KAPPA POWER. C A GUESS PARCEL TEMPERATURE MUST BE PROVIDED. C EQUIVALENT POTENTIAL TEMPERATURE IS CONSTANT FOR A SATURATED PARCEL C RISING ADIABATICALLY UP A MOIST ADIABAT WHEN THE HEAT AND MASS C OF THE CONDENSED WATER ARE NEGLECTED. THE FORMULA FOR C EQUIVALENT POTENTIAL TEMPERATURE (DERIVED IN HOLTON) IS C THE=T*(PD**(-ROCP))*EXP(EL*EPS*PV/(CP*T*PD)) C WHERE T IS THE TEMPERATURE, PV IS THE SATURATED VAPOR PRESSURE, C PD IS THE DRY PRESSURE P-PV, EL IS THE TEMPERATURE DEPENDENT C LATENT HEAT OF CONDENSATION HVAP+DLDT*(T-TTP), AND OTHER VALUES C ARE PHYSICAL CONSTANTS DEFINED IN PARAMETER STATEMENTS IN THE CODE. C THE FORMULA IS INVERTED BY ITERATING NEWTONIAN APPROXIMATIONS C FOR EACH THE AND P UNTIL T IS FOUND TO WITHIN 1.E-4 KELVIN. C THE SPECIFIC HUMIDITY IS THEN COMPUTED FROM PV AND PD. C THIS FUNCTION CAN BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL EXACT COMPUTATION C C USAGE: TMA=FTMAXG(TG,THE,PK,QMA) C C INPUT ARGUMENT LIST: C TG - REAL GUESS PARCEL TEMPERATURE IN KELVIN C THE - REAL EQUIVALENT POTENTIAL TEMPERATURE IN KELVIN C PK - REAL PRESSURE OVER 100 KPA TO THE KAPPA POWER C C OUTPUT ARGUMENT LIST: C FTMAXG - REAL PARCEL TEMPERATURE IN KELVIN C QMA - REAL PARCEL SPECIFIC HUMIDITY IN KG/KG C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ,RV= 4.6150E+2 , & TTP= 2.7316E+2 ,HVAP= 2.5000E+6 ,PSAT= 6.1078E+2 , & CLIQ= 4.1855E+3 ,CVAP= 1.8460E+3 ) PARAMETER(PSATK=PSAT*1.E-3) PARAMETER(ROCP=RD/CP,CPOR=CP/RD,PSATB=PSATK*1.E-2,EPS=RD/RV, & DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)) PARAMETER(TERRM=1.E-4) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - T=TG P=PK**CPOR TR=TTP/T PV=PSATB*(TR**XA)*EXP(XB*(1.-TR)) PD=P-PV EL=HVAP+DLDT*(T-TTP) EXPO=EL*EPS*PV/(CP*T*PD) THET=T*PD**(-ROCP)*EXP(EXPO) DTHET=THET/T*(1.+EXPO*(DLDT*T/EL+EL*P/(RV*T*PD))) TERR=(THET-THE)/DTHET T=T-TERR DOWHILE(ABS(TERR).GT.TERRM) TR=TTP/T PV=PSATB*(TR**XA)*EXP(XB*(1.-TR)) PD=P-PV EL=HVAP+DLDT*(T-TTP) EXPO=EL*EPS*PV/(CP*T*PD) THET=T*PD**(-ROCP)*EXP(EXPO) DTHET=THET/T*(1.+EXPO*(DLDT*T/EL+EL*P/(RV*T*PD))) TERR=(THET-THE)/DTHET T=T-TERR ENDDO FTMAXG=T TR=TTP/T PV=PSATB*(TR**XA)*EXP(XB*(1.-TR)) PD=P-PV QMA=EPS*PV/(PD+EPS*PV) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R C SUBROUTINE GPKAP C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GPKAP COMPUTE COEFFICIENTS FOR P**KAPPA C AUTHOR: PHILLIPS ORG: W/NMC2X2 DATE: 29 DEC 82 C C ABSTRACT: COMPUTE A RATIONAL WEIGHTED CHEBYSHEV APPROXIMATION TO C PRESSURE RAISED TO THE KAPPA POWER FOR USE BY THE FUNCTION FPKAP. C THE NUMERATOR IS OF ORDER 2 AND THE DENOMINATOR IS OF ORDER 4. C THE PRESSURE RANGE IS 40-110 KPA AND KAPPA IS DEFINED IN FPKAPX. C IMSL SUBPROGRAM RATCH IS USED TO COMPUTE COEFFICIENTS. C C PROGRAM HISTORY LOG: C 94-12-30 IREDELL C C USAGE: CALL GPKAP C C SUBPROGRAMS CALLED: C RATCH - IMSL RATIONAL WEIGHTED CHEBYSHEV APPROXIMATION C FPKAPX - FUNCTION TO COMPUTE EXACT PRESSURE TO THE KAPPA C FIDENT - IDENTITY FUNCTION C C COMMON BLOCKS: C COMPKAP - COEFFICIENTS FOR FUNCTION FPKAP C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ C COMMON/COMPKAP/ CN0,CN1,CN2,CD0,CD1,CD2,CD3,CD4 C EXTERNAL FPKAPX,FIDENT C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CCRA CALL RATCH(FPKAPX,FIDENT,FPKAPX,40.,110.,2,4,CN0,CD0,ERROR) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C RETURN C END C----------------------------------------------------------------------- FUNCTION FIDENT(X) FIDENT=X RETURN END C----------------------------------------------------------------------- BLOCK DATA BDPKAP C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BDPKAP SET DEFAULT COEFFICIENTS FOR P**KAPPA C AUTHOR: PHILLIPS ORG: W/NMC2X2 DATE: 29 DEC 82 C C ABSTRACT: SET DEFAULT COEFFICIENTS FOR P**KAPPA. SUBPROGRAM GPKAP WAS C USED TO COMPUTE A RATIONAL WEIGHTED CHEBYSHEV APPROXIMATION TO C PRESSURE RAISED TO THE KAPPA POWER FOR USE BY THE FUNCTION FPKAP. C THE NUMERATOR IS OF ORDER 2 AND THE DENOMINATOR IS OF ORDER 4. C THE PRESSURE RANGE IS 40-110 KPA AND KAPPA IS 287.05/1004.6. C IMSL SUBPROGRAM RATCH IS USED TO COMPUTE COEFFICIENTS. C SEE SUBPROGRAMS GPKAP AND FPKAP FOR MORE DETAILS. C C PROGRAM HISTORY LOG: C 94-12-30 IREDELL C C COMMON BLOCKS: C COMPKAP - COEFFICIENTS FOR FUNCTION FPKAP C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ COMMON/COMPKAP/ CN0,CN1,CN2,CD0,CD1,CD2,CD3,CD4 DATA CN0,CN1,CN2 & / 3.13198449E-1,5.78544829E-2, 8.35491871E-4/ DATA CD0,CD1,CD2,CD3,CD4 & /1.,8.15968401E-2,5.72839518E-4,-4.86959812E-7,5.24459889E-10/ END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FPKAP(P) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FPKAP RAISE SURFACE PRESSURE TO THE KAPPA POWER. C AUTHOR: PHILLIPS ORG: W/NMC2X2 DATE: 29 DEC 82 C C ABSTRACT: RAISE SURFACE PRESSURE OVER 100 KPA TO THE KAPPA POWER C USING A RATIONAL WEIGHTED CHEBYSHEV APPROXIMATION. C THE NUMERATOR IS OF ORDER 2 AND THE DENOMINATOR IS OF ORDER 4. C THE PRESSURE RANGE IS 40-110 KPA AND KAPPA IS DEFINED IN FPKAPX. C THE COEFFIECIENTS ARE SET BY CALLING GPKAP OR INCLUDING BDPKAP. C THE ACCURACY OF THIS APPROXIMATION IS ALMOST 8 DECIMAL PLACES. C ON THE CRAY, FPKAP IS OVER 10 TIMES FASTER THAN EXACT CALCULATION. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C 94-12-30 IREDELL STANDARDIZED KAPPA, C INCREASED RANGE AND ACCURACY C C USAGE: PKAP=FPKAP(P) C C INPUT ARGUMENT LIST: C P - REAL SURFACE PRESSURE IN KILOPASCALS (CB) C P SHOULD BE IN THE RANGE 40. TO 110. C C OUTPUT ARGUMENT LIST: C FPKAP - REAL P/100 TO THE KAPPA POWER C C COMMON BLOCKS: C COMPKAP - COEFFICIENTS FOR FUNCTION FPKAP C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ COMMON/COMPKAP/ CN0,CN1,CN2,CD0,CD1,CD2,CD3,CD4 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - FPKAP=(CN0+P*(CN1+P*CN2))/(CD0+P*(CD1+P*(CD2+P*(CD3+P*CD4)))) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FPKAPX(P) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FPKAPX RAISE SURFACE PRESSURE TO THE KAPPA POWER. C AUTHOR: PHILLIPS ORG: W/NMC2X2 DATE: 29 DEC 82 C C ABSTRACT: RAISE SURFACE PRESSURE OVER 100 KPA TO THE KAPPA POWER. C KAPPA IS EQUAL TO RD/CP WHERE RD AND CP ARE PHYSICAL CONSTANTS. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 94-12-30 IREDELL MADE INTO INLINABLE FUNCTION C C USAGE: PKAP=FPKAPX(P) C C INPUT ARGUMENT LIST: C P - REAL SURFACE PRESSURE IN KILOPASCALS (CB) C C OUTPUT ARGUMENT LIST: C FPKAPX - REAL P/100 TO THE KAPPA POWER C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ) PARAMETER(ROCP=RD/CP) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - FPKAPX=(P/100.)**ROCP C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R FUNCTION FTLCL(T,TDPD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FTLCL COMPUTE LCL TEMPERATURE. C AUTHOR: PHILLIPS ORG: W/NMC2X2 DATE: 29 DEC 82 C C ABSTRACT: COMPUTE TEMPERATURE AT THE LIFTING CONDENSATION LEVEL C FROM TEMPERATURE AND DEWPOINT DEPRESSION. THE FORMULA USED IS C A POLYNOMIAL TAKEN FROM PHILLIPS MSTADB ROUTINE WHICH EMPIRICALLY C APPROXIMATES THE ORIGINAL EXACT IMPLICIT RELATIONSHIP. C (THIS KIND OF APPROXIMATION IS CUSTOMARY (INMAN, 1969), BUT C THE ORIGINAL SOURCE FOR THIS PARTICULAR ONE IS NOT YET KNOWN. -MI) C ITS ACCURACY IS ABOUT 0.03 KELVIN FOR A DEWPOINT DEPRESSION OF 30. C THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION C C USAGE: TLCL=FTLCL(T,TDPD) C C INPUT ARGUMENT LIST: C T - REAL TEMPERATURE IN KELVIN C TDPD - REAL DEWPOINT DEPRESSION IN KELVIN C C OUTPUT ARGUMENT LIST: C FTLCL - REAL TEMPERATURE AT THE LCL IN KELVIN C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ PARAMETER(CLCL1= 0.954442E+0,CLCL2= 0.967772E-3, & CLCL3=-0.710321E-3,CLCL4=-0.270742E-5) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - FTLCL=T-TDPD*(CLCL1+CLCL2*T+TDPD*(CLCL3+CLCL4*T)) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END CFPP$ NOCONCUR R SUBROUTINE GBPHYS(PLAMGRS,PPHIGRS,UGRS,VGRS,PGR,TGRS,QGRS,XGRS, X PSLAP, X GT0,GQ0,GU0,GV0, X TGMXL,IGMXL,KGMXL,TGMNL,IGMNL,KGMNL, X GDA, C-RASX RAS,LMX,CP,ALHL,GRAV,RGAS, C-RASX SIG, SGB, PRH, PRJ, HPK, FPK, ODS, PRNS, C-RASX RASAL, LM, KRMIN, KRMAX, NSTRP, C-RASX NCRND, RANNUM, AFAC, UFAC, X LAT) C................................................................. CFPP$ EXPAND(ZNLACM,ACCDIA) C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) PARAMETER(NVRKEN= 80 + 8 * 28 ,NPTKEN= 30 ) PARAMETER(NSTKEN= 48 ) COMMON/COMGPD/ SVDATA(NVRKEN,NPTKEN,NSTKEN), 1 IGRD(NPTKEN),JGRD(NPTKEN), 2 IGRDR(NPTKEN),JGRDR(NPTKEN), 3 ITNUM,NPOINT,ISAVE,ISSHRT,ILSHRT,IKFREQ PARAMETER(CNWATT=- 4.1855E+0 *1.E4/60.,FV= 4.6150E+2 / 2.8705E+2 - 11.) DIMENSION IPTLAT(NPTKEN) DIMENSION JPTLAT(NPTKEN) C-WAV COMMON/COMWAV/ HSTR,USTRGG( 384 , 47 ),VSTRGG( 384 , 47 ) C................................................................... C WARNING: GT0,GQ0,GU0,GV0 MAY OVERLAY TGRS,QGRS,UGRS,VGRS RESPECTIVELY. DIMENSION PLAMGRS( 386 ) DIMENSION PPHIGRS( 386 ) DIMENSION UGRS( 386 , 28 ) DIMENSION VGRS( 386 , 28 ) DIMENSION PGR( 386 ) DIMENSION TGRS( 386 , 28 ) DIMENSION QGRS( 386 , 28 ) DIMENSION XGRS( 386 , 28 ) DIMENSION GT0( 386 , 28 ) DIMENSION GQ0( 386 , 28 ) DIMENSION GU0( 386 , 28 ) DIMENSION GV0( 386 , 28 ) C DIMENSION PSLAP( 386 ) C................................................................... DIMENSION SLK( 28 ) C................................................................. DIMENSION KBOT( 384 ),KTOP( 384 ),KUO( 384 ), 1DUDT( 384 , 28 ),DVDT( 384 , 28 ), 2DTDT( 384 , 28 ),DQDT( 384 , 28 ), 2 HSW( 384 , 28 ),GFLX( 384 ), 3 RAIN( 384 ),RAINC( 384 ),RAINL( 384 ),RAIN1( 384 ), 4 EVAPC( 384 ),WORK1( 384 ),WIND( 384 ), 5 W2( 384 , 28 ),VVEL( 384 , 28 ) C................................................................. DIMENSION TSTAR( 384 ), PSEXP( 384 ), 1 SNOWMT( 384 ),FACTOR( 384 ), 1 SNOWEV( 384 ),SNOWFL( 384 ), 2 FM( 384 ), FH( 384 ), 3 CD( 384 ), CDQ( 384 ), 4 QSS( 384 ), RADSL( 384 ) DIMENSION DUSFCG( 384 ),DVSFCG( 384 ) DIMENSION DUSFC1( 384 ),DVSFC1( 384 ), 1 DTSFC1( 384 ),DQSFC1( 384 ), 1 DLWSF1( 384 ),ULWSF1( 384 ) DIMENSION SMSOIL( 384 , 2 ),STSOIL( 384 , 2 ) DIMENSION SOILTYP( 384 ),SIGMAF( 384 ) DIMENSION RB( 384 ),RHSCNPY( 384 ) DIMENSION AI( 384 , 2 ),BI( 384 , 2 ),DRAIN( 384 ) DIMENSION CCI( 384 , 2 ),RHSMC( 384 , 2 ),RUNOF( 384 ) DIMENSION ZSOIL( 384 , 2 ),CLD1D( 384 ) DIMENSION EVAP( 384 ),HFLX( 384 ),RNET( 384 ) DIMENSION T850( 384 ),PK( 384 ),PKP( 384 ),EP1D( 384 ) DIMENSION GAMT( 384 ),GAMQ( 384 ) DIMENSION QCICNV( 384 , 28 ),QRSCNV( 384 , 28 ) INTEGER SOILTYP DIMENSION TOVZER( 28 ) DIMENSION GDA(NWGDA,KDGDA) C-RAS LOGICAL RAS C-RAS DIMENSION SIG(LMX+1), PRJ(LMX+1), PRH(LMX), FPK(LMX), HPK(LMX) C-RAS*, SGB(LMX), ODS(LMX), RASAL(LMX), PRNS(LMX/2) C-RAS*, RANNUM(LMX) C-RAS DIMENSION WRK( 384 *(27+15*LMX)) LOGICAL LDIAG C PARAMETER (HFUS= 3.3358E+5 ,RHOH2O=1000.) C SIGSHC=0.7 LEVSHC=0 P850 = 850. * .1 dxmeter = 12600000./ 62 C C FRAIN IS THE FACTOR FOR CENTERED DIFFERENCE SCHEME CORRECTION OF RAIN C AMOUNT. C FRAIN = .5 IF(INISTP.EQ.1) FRAIN = 1. DO 205 K=1, 28 IF(SL(K).GT.SIGSHC) LEVSHC=K+1 SLK(K)=SL(K)**( 2.8705E+2 / 1.0046E+3 ) 205 TOVZER(K)=0. E 0 MSTA=0 LDIAG=.FALSE. C C FOR THE TIME BEING, SOILTYP AND SIGMAF WILL BE SET TO CONSTANT C WE PLAN TO BRING IN A DATA SET FOR EACH C AT A LATTER TIME C DO J = 1, 384 SOILTYP(J) = 7 SIGMAF(J) = .7 ENDDO C SL1=SL(1) FACTX=1000. E 0*(DELTIM*DEL(1)/ 9.8000E+0 ) CSTRN2=1. E 0/(.75 E 0*150. E 0) DT2=DELTIM*2. E 0 DTF=FRAIN*DT2 C C TRANSFER SOIL MOISTURE AND TEMPERATURE FROM GLOBAL TO LOCAL VARIABLES C DO K = 1, 2 DO J = 1, 384 SMSOIL(J,K) = SMC(J,LAT,K) STSOIL(J,K) = STC(J,LAT,K) ENDDO ENDDO C DO 240 K=1, 28 DO 240 J=1, 384 DUDT(J,K)=0. E 0 DVDT(J,K)=0. E 0 DTDT(J,K)=0. E 0 DQDT(J,K)=0. E 0 240 CONTINUE RCL=RBS2(LAT) RCS = SQRT(RCL) C................................................................. C C GET DRY TEP. C DO 270 K=1, 28 DO 270 J=1, 384 TGRS(J,K)=TGRS(J,K)/(1.+FV*QGRS(J,K)) 270 CONTINUE DO 271 K=1, 28 J=ISMAX( 384 ,TGRS(1,K),1) IF(TGRS(J,K).GT.TGMXL) THEN TGMXL=TGRS(J,K) IGMXL=J KGMXL=K ENDIF J=ISMIN( 384 ,TGRS(1,K),1) IF(TGRS(J,K).LT.TGMNL) THEN TGMNL=TGRS(J,K) IGMNL=J KGMNL=K ENDIF 271 CONTINUE C C GET SURFACE PRESSURE. C DO 280 J=1, 384 PSEXP(J)= EXP(PGR(J)) FACTOR(J)=FACTX*PSEXP(J) PSURF(J,LAT)=PSEXP(J) PSMEAN(J,LAT)=PSMEAN(J,LAT)+PSEXP(J)*DTF 280 CONTINUE C C INITIALIZE DTDT WITH HEATING RATE FROM DCYC2 AND GET RADSL FOR PROGTM C C-LFC IF(1.NE.1) THEN CALL DCYC2( 384 , 28 ,SOLHR,SLAG,SINLAB(1,LAT),COSLAB(1,LAT), & SDEC,CDEC,XLON(1,LAT),COSZEN(1,LAT), & SFCDLW(1,LAT),SFCNSW(1,LAT),TGRS(1,1), & TSEA(1,LAT),TSFLW(1,LAT),SWH(1,1,LAT),HLW(1,1,LAT), & DLWSF1,ULWSF1,RADSL,DTDT) C-LFC ELSE C-LFC DO I=1, 384 C-LFC RADSL(I)=SFCNSW(I,LAT)+SFCDLW(I,LAT) C-LFC DLWSF1(I)=SFCDLW(I,LAT)*(- 4.1855E+0 *1.E4/60.) C-LFC ULWSF1(I)= 5.6730E-8 *TSEA(I,LAT)**4 C-LFC ENDDO C-LFC DO K=1, 28 C-LFC DO I=1, 384 C-LFC DTDT(I,K)=DTDT(I,K)+SWH(I,K,LAT)+HLW(I,K,LAT) C-LFC ENDDO C-LFC ENDDO C-LFC ENDIF C DO 285 J=1, 384 DLWSFC(J,LAT)=DLWSFC(J,LAT)+DLWSF1(J)*DTF ULWSFC(J,LAT)=ULWSFC(J,LAT)+ULWSF1(J)*DTF 285 CONTINUE C DO 286 K=1, 28 DO 286 J=1, 384 HSW(J,K)=DTDT(J,K)-HLW(J,K,LAT) 286 CONTINUE CALL ZNLACM( 384 ,HSW,PSEXP, DTF,NMTHSW,LAT) CALL ZNLACM( 384 ,HLW(1,1,LAT),PSEXP, DTF,NMTHLW,LAT) CALL ACCDIA( 384 ,HSW, DTF,KDTHSW,GDA) CALL ACCDIA( 384 ,HLW(1,1,LAT), DTF,KDTHLW,GDA) C C-DBG print *,'----- GBPHYS ----- LAT=',LAT C-DBG level=1 C numlevs= 28 C-DBG numlevs=1 C-DBG print *,'UGRS ' C-DBG call maxmin(UGRS(1,level), 386 , 28 , 384 ,numlevs,1) C-DBG print *,'VGRS ' C-DBG call maxmin(VGRS(1,level), 386 , 28 , 384 ,numlevs,1) C-DBG print *,'TGRS ' C-DBG call maxmin(TGRS(1,level), 386 , 28 , 384 ,numlevs,1) C-DBG print *,'QGRS ' C-DBG call maxmin(QGRS(1,level), 386 , 28 , 384 ,numlevs,1) C-DBG print *,' ' C-DBG print *,'HSW ' C-DBG call maxmin(HSW(1,level), 384 , 28 , 384 ,numlevs,1) C-DBG print *,'HLW ' C-DBG call maxmin(HLW(1,level,LAT), 384 , 28 , 384 ,numlevs,1) C-DBG print *,' ' C-DBG print *,'SHELEG ' C-DBG call maxmin(SHELEG(1,LAT), 384 , 1, 384 , 1,1) C-DBG print *,'TSEA ' C-DBG call maxmin(TSEA(1,LAT), 384 , 1, 384 , 1,1) C-DBG print *,'SMSOIL1 ' C-DBG call maxmin(SMSOIL(1,1), 384 , 1, 384 , 1,1) C-DBG print *,'SMSOIL2 ' C-DBG call maxmin(SMSOIL(1,2), 384 , 1, 384 , 1,1) C-DBG print *,'STSOIL1' C-DBG call maxmin(STSOIL(1,1), 384 , 1, 384 , 1,1) C-DBG print *,'STSOIL2' C-DBG call maxmin(STSOIL(1,2), 384 , 1, 384 , 1,1) C-DBG print *,'CANOPY ' C-DBG call maxmin(CANOPY(1,LAT), 384 , 1, 384 , 1,1) C-DBG print *,'ZORL ' C-DBG call maxmin(ZORL(1,LAT), 384 , 1, 384 , 1,1) C-DBG print *,'PLANTR ' C-DBG call maxmin(PLANTR(1,LAT), 384 , 1, 384 , 1,1) C-DBG print *,'TG3 ' C-DBG call maxmin(TG3(1,LAT), 384 , 1, 384 , 1,1) C-DBG print *,'SLMSK ' C-DBG call maxmin(SLMSK(1,LAT), 384 , 1, 384 , 1,1) CALL PROGTM( 384 , 2 ,PSEXP, 1 UGRS(1,1),VGRS(1,1), 1 TGRS(1,1),QGRS(1,1), 2 SHELEG(1,LAT),TSEA(1,LAT),QSS, & SMSOIL,STSOIL,EVAPC,SOILTYP,SIGMAF,CANOPY(1,LAT), 3 RADSL,SNOWMT,SNOWEV, 3 DELTIM,ZORL(1,LAT),PLANTR(1,LAT),TG3(1,LAT), 4 GFLX,F10M(1,LAT),U10M(1,LAT),V10M(1,LAT),T2M(1,LAT),Q2M(1,LAT), 5 ZSOIL,CD,CDQ,RB,RHSCNPY,RHSMC,AI,BI,CCI, 6 RCL,SL1,SLK,SLMSK(1,LAT),INISTP,LAT, & DRAIN,EVAP,HFLX,RNET,EP1D,COWAVE,FM,FH,WIND) C-DBG print *,'TSEA after PROGTM' C-DBG call maxmin(TSEA(1,LAT), 384 , 1, 384 , 1,1) C DO 290 J=1, 384 SNOWEVAP(J,LAT) = SNOWEVAP(J,LAT) + SNOWEV(J)*DELTIM GFLUX(J,LAT)=GFLUX(J,LAT)+GFLX(J)*DTF TMPMAX(J,LAT) = MAX(TMPMAX(J,LAT),T2M(J,LAT)) TMPMIN(J,LAT) = MIN(TMPMIN(J,LAT),T2M(J,LAT)) EP(J,LAT) = EP(J,LAT) + EP1D(J) * DTF 290 CONTINUE C C COMPUTE COEFFICIENT OF EVAPORATION IN EVAPC C DO 320 J=1, 384 TSTAR(J) = TSEA(J,LAT) IF (EVAPC(J).GT.1. E 0) EVAPC(J)=1.0 E 0 320 CONTINUE C-DBG print *,'TSTAR in GBPHYS' C-DBG call maxmin(TSTAR, 384 ,1, 384 ,1,1) C-DBG print *,'QSS in GBPHYS' C-DBG call maxmin(QSS, 384 ,1, 384 ,1,1) C C OVER SNOW COVER OR ICE OR SEA, COEF OF EVAP =1.0. E 0 C DO 330 J=1, 384 IF ((SHELEG(J,LAT).GT.0. E 0) .OR. 1 (SLMSK(J,LAT).NE.1. E 0)) 2 EVAPC(J)=1. E 0 330 CONTINUE C C DO VERTICAL DIFFUSION C CALL ZNLACM( 384 ,DTDT,PSEXP,-DTF,NMTVRDF,LAT) CALL ACCDIA( 384 ,DTDT,-DTF,KDTVRDF,GDA) CALL MONINP( 384 , 386 , 28 ,DVDT,DUDT, 1 DTDT,DQDT, 1 UGRS(1,1),VGRS(1,1), 1 TGRS(1,1),QGRS(1,1), 2 PSEXP,RB,CD, 4 CDQ,FM,FH,TSTAR,QSS,EVAPC,WIND, 5 SI,DEL,SL,SLK,RCL,DELTIM,LAT,KDT,THOUR, 6 DUSFC1,DVSFC1,DTSFC1,DQSFC1,HPBL(1,LAT),GAMT,GAMQ,SLMSK) C C-DBG print *,' monin' C-DBG print *,'DUDT ' C-DBG call maxmin(DUDT(1,level), 384 , 1, 384 , numlevs,1) C-DBG print *,'DVDT ' C-DBG call maxmin(DVDT(1,level), 384 , 1, 384 , numlevs,1) C-DBG print *,'DTDT ' C-DBG call maxmin(DTDT(1,level), 384 , 1, 384 , numlevs,1) C-DBG print *,'DQDT ' C-DBG call maxmin(DQDT(1,level), 384 , 1, 384 , numlevs,1) C DO 340 J=1, 384 DUSFC(J,LAT)=DUSFC(J,LAT)+DUSFC1(J)*DTF DVSFC(J,LAT)=DVSFC(J,LAT)+DVSFC1(J)*DTF DTSFC(J,LAT)=DTSFC(J,LAT)+DTSFC1(J)*DTF DQSFC(J,LAT)=DQSFC(J,LAT)+DQSFC1(J)*DTF C-WAV IF(DTWAVE.GT.0.) THEN C-WAV USTRGG(J,LAT)=USTRGG(J,LAT)+DUSFC1(J)*DTF C-WAV VSTRGG(J,LAT)=VSTRGG(J,LAT)+DVSFC1(J)*DTF C-WAV ENDIF 340 CONTINUE C CALL GWDPS( 384 , 386 , 28 ,DVDT,DUDT, 1 UGRS(1,1),VGRS(1,1), 2 TGRS(1,1),QGRS(1,1), 3 PSEXP,SI,DEL,CL,SL,RCL,DELTIM,LAT,KDT,HPRIME(1,LAT), 4 DUSFCG,DVSFCG) C C-DBG print *,' gwd' C-DBG print *,'DUDT ' C-DBG call maxmin(DUDT(1,level), 384 , 1, 384 , numlevs,1) C-DBG print *,'DVDT ' C-DBG call maxmin(DVDT(1,level), 384 , 1, 384 , numlevs,1) C DO 341 J=1, 384 DUGWD(J,LAT)=DUGWD(J,LAT)+DUSFCG(J)*DTF DVGWD(J,LAT)=DVGWD(J,LAT)+DVSFCG(J)*DTF 341 CONTINUE C CALL ZNLACM( 384 ,DUDT,PSEXP, DTF,NMUVRDF,LAT) CALL ZNLACM( 384 ,DVDT,PSEXP, DTF,NMVVRDF,LAT) CALL ZNLACM( 384 ,DTDT,PSEXP, DTF,NMTVRDF,LAT) CALL ZNLACM( 384 ,DQDT,PSEXP, DTF,NMQVRDF,LAT) CALL ACCDIA( 384 ,DUDT, DTF,KDUVRDF,GDA) CALL ACCDIA( 384 ,DVDT, DTF,KDVVRDF,GDA) CALL ACCDIA( 384 ,DTDT, DTF,KDTVRDF,GDA) CALL ACCDIA( 384 ,DQDT, DTF,KDQVRDF,GDA) IF(INISTP.LE.1) THEN C....................................................... C... GET VERTICAL MOTION (CB/SEC) IN VVEL C....................................................... CALL OMEGAS( 384 , 386 , 28 , 1 PPHIGRS(1),PLAMGRS(1),W2, 1 UGRS(1,1),VGRS(1,1), 2 XGRS(1,1),DEL,RBS2(LAT),VVEL, 3 PSEXP,SL) ENDIF C C W2 IS USED TO STORE WIND SPEED C DO K=1, 28 DO J=1, 384 W2(J,K)=RCS*SQRT(UGRS(J,K)**2+VGRS(J,K)**2) ENDDO ENDDO C DO 350 K=1, 28 DO 350 J=1, 384 GT0(J,K)=TGRS(J,K)+DTDT(J,K)*DT2 GQ0(J,K)=QGRS(J,K)+DQDT(J,K)*DT2 GU0(J,K)=UGRS(J,K)+DUDT(J,K)*DT2 GV0(J,K)=VGRS(J,K)+DVDT(J,K)*DT2 350 CONTINUE C C-DBG print *,'GT0 ' C-DBG call maxmin(GT0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GQ0 ' C-DBG call maxmin(GQ0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GU0 ' C-DBG call maxmin(GU0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GV0 ' C-DBG call maxmin(GV0(1,level), 386 , 1, 384 , numlevs,1) C C CALL TO GWATER C IF(INISTP.LE.1) THEN C..... CALL ZNLACM( 386 ,GT0(1,1),PSEXP,-FRAIN,NMTCONV,LAT) CALL ZNLACM( 386 ,GQ0(1,1),PSEXP,-FRAIN,NMQCONV,LAT) CALL ACCDIA( 386 ,GT0(1,1),-FRAIN,KDTCONV,GDA) CALL ACCDIA( 386 ,GQ0(1,1),-FRAIN,KDQCONV,GDA) C-RAS IF (.NOT. RAS) THEN CALL SASCNV( 384 , 386 , 28 , 62 ,DELTIM,DEL,SL,SLK,PSEXP, 2 GQ0(1,1),GT0(1,1),CLD1D, 3 RAIN1,KBOT,KTOP,KUO,W2,LAT,SLMSK(1,LAT),VVEL, 4 HPBL(1,LAT),GAMT,GAMQ,QCICNV,QRSCNV,DXMETER) C C-DBG print *,'sascnv' C-DBG print *,'GT0 ' C-DBG call maxmin(GT0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GQ0 ' C-DBG call maxmin(GQ0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GU0 ' C-DBG call maxmin(GU0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GV0 ' C-DBG call maxmin(GV0(1,level), 386 , 1, 384 , numlevs,1) C-RAS ELSE C-RAS DTRAS = DELTIM / FRAIN C-RAS IL1R = 1 + 8 * 384 C-RAS IL2R = IL1R + 10 * 384 * LM C-RAS IL3R = IL2R + 384 * (5*LM+16) C-RAS CALL RASCNV( 384 , 386 , 28 , LM, NSTRP, DTRAS, SI, SL C-RAS*, KRMIN, KRMAX, NCRND, AFAC, RANNUM, UFAC C-RAS*, RGAS, CP, GRAV, ALHL C-RAS*, GT0(1,1), GQ0(1,1) C-RAS*, GU0(1,1), GV0(1,1), PSEXP C-RAS*, RAIN1, KBOT, KTOP, KUO, LAT, SLMSK C-RAS*, SIG, PRJ, PRH, FPK, HPK, SGB, ODS, RASAL, PRNS C-RAS*, WRK(1), WRK(IL1R), WRK(IL2R) C-RAS*, WRK(IL3R), VVEL) C-RAS DO J=1, 384 C-RAS CLD1D(J)=0. C-RAS ENDDO C-RAS ENDIF DO J=1, 384 CLDWRK(J,LAT) = CLDWRK(J,LAT) + CLD1D(J) * DTF ENDDO C DO 235 J=1, 384 RAINC(J)=FRAIN*RAIN1(J) BENGSH(J,LAT)=BENGSH(J,LAT)+RAINC(J) 235 CONTINUE CALL CNVCLD(CLSTP, 384 ,RAINC,KBOT,KTOP, 1 CV(1,LAT),CVB(1,LAT),CVT(1,LAT)) C CALL ZNLACM( 386 ,GT0(1,1),PSEXP, FRAIN,NMTCONV,LAT) CALL ZNLACM( 386 ,GQ0(1,1),PSEXP, FRAIN,NMQCONV,LAT) CALL ACCDIA( 386 ,GT0(1,1), FRAIN,KDTCONV,GDA) CALL ACCDIA( 386 ,GQ0(1,1), FRAIN,KDQCONV,GDA) C..... CALL ZNLACM( 386 ,GT0(1,1),PSEXP,-FRAIN,NMTSHAL,LAT) CALL ZNLACM( 386 ,GQ0(1,1),PSEXP,-FRAIN,NMQSHAL,LAT) CALL ACCDIA( 386 ,GT0(1,1),-FRAIN,KDTSHAL,GDA) CALL ACCDIA( 386 ,GQ0(1,1),-FRAIN,KDQSHAL,GDA) CALL SHALCV( 384 , 386 ,LEVSHC,DELTIM,DEL,SI,SL,SLK,KUO,PSEXP, 1 GQ0(1,1),GT0(1,1)) C-DBG print *,'shalcv' C-DBG print *,'GT0 ' C-DBG call maxmin(GT0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GQ0 ' C-DBG call maxmin(GQ0(1,level), 386 , 1, 384 , numlevs,1) CALL ZNLACM( 386 ,GT0(1,1),PSEXP, FRAIN,NMTSHAL,LAT) CALL ZNLACM( 386 ,GQ0(1,1),PSEXP, FRAIN,NMQSHAL,LAT) CALL ACCDIA( 386 ,GT0(1,1), FRAIN,KDTSHAL,GDA) CALL ACCDIA( 386 ,GQ0(1,1), FRAIN,KDQSHAL,GDA) C..... CALL ZNLACM( 386 ,GT0(1,1),PSEXP,-FRAIN,NMTLARG,LAT) CALL ACCDIA( 386 ,GT0(1,1),-FRAIN,KDTLARG,GDA) CALL LRGSCL( 384 , 386 , 28 ,DELTIM,PSEXP, 1 GT0(1,1),GQ0(1,1),SL,DEL,SLK, & RAIN1,LAT) CALL ZNLACM( 386 ,GT0(1,1),PSEXP, FRAIN,NMTLARG,LAT) CALL ACCDIA( 386 ,GT0(1,1), FRAIN,KDTLARG,GDA) C-DBG print *,'lrgscl' C-DBG print *,'GT0 ' C-DBG call maxmin(GT0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GQ0 ' C-DBG call maxmin(GQ0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GU0 ' C-DBG call maxmin(GU0(1,level), 386 , 1, 384 , numlevs,1) C-DBG print *,'GV0 ' C-DBG call maxmin(GV0(1,level), 386 , 1, 384 , numlevs,1) C DO 440 J=1, 384 RAINL(J)=FRAIN*RAIN1(J) RAIN(J)=RAINC(J)+RAINL(J) GESHEM(J,LAT)=GESHEM(J,LAT)+RAIN(J) 440 CONTINUE C C ESTIMATE T850 FOR RAIN-SNOW DECISION C DO J = 1, 384 PK(J) = PSEXP(J) * SL(1) T850(J) = GT0(J,1) ENDDO DO K = 1, 28 - 1 DO J = 1, 384 PKP(J) = PSEXP(J) * SL(K+1) CHH IF(PK(J) .LE. P850 .AND. PKP(J) .GT. P850) THEN IF(PK(J) .GT. P850 .AND. PKP(J) .LE. P850) THEN T850(J) = GT0(J,K) - (PK(J) - P850) / & (PK(J) - PKP(J)) * (GT0(J,K) & - GT0(J,K+1)) ENDIF PK(J) = PKP(J) ENDDO ENDDO C C FACTOR=WEIGHTED MEAN TEP. C DO 450 J=1, 384 IF(T850(J).LE.273.16) THEN SNOWFL(J)=RAIN(J) IF(SLMSK(J,LAT).NE.0.) THEN SHELEG(J,LAT)=SHELEG(J,LAT)+1.E3*RAIN(J) SNOWFALL(J,LAT)=SNOWFALL(J,LAT)+RAIN(J) ENDIF RAIN(J)=0. ELSE SNOWFL(J)=0. ENDIF 450 CONTINUE C C UPDATE SOIL MOISTURE AND CANOPY WATER AFTER PRECIPITATION HAS BEEN C COMPUTED C CALL PROGT2( 384 , 2 ,RHSCNPY,RHSMC,AI,BI,CCI,SMSOIL, & SLMSK(1,LAT),CANOPY(1,LAT),RAIN,RUNOF,SNOWMT, & ZSOIL,SOILTYP,SIGMAF,DELTIM,LAT) C C TOTAL RUNOFF IS COMPOSED OF DRAINAGE INTO WATER TABLE AND C RUNOFF AT THE SURFACE AND IS ACCUMULATED IN UNIT OF METERS C DO J = 1, 384 RUNOFF(J,LAT) = (DRAIN(J) + RUNOF(J)) * DTF / 1000. & + RUNOFF(J,LAT) SNOWMELT(J,LAT) = SNOWMELT(J,LAT) + 1 SNOWMT(J)*DELTIM*HFUS*RHOH2O ENDDO C C RETURN UPDATED SMSOIL AND STSOIL TO GLOBAL ARRAYS C DO K = 1, 2 DO J = 1, 384 SMC(J,LAT,K) = SMSOIL(J,K) STC(J,LAT,K) = STSOIL(J,K) ENDDO ENDDO ENDIF C C ZONAL DIAGNOSTICS C IF(LASTEP) THEN SECPHY=SHOUR SECRAD=MAX(SHOUR,3600.*DTSWAV) CALL ZNLAVB(LAT, 384 , 386 , 28 ,SECPHY,SECRAD, & RBS2(LAT),SI,SL,DEL,PSEXP,GESHEM(1,LAT),BENGSH(1,LAT), & DUSFC(1,LAT),DVSFC(1,LAT),DTSFC(1,LAT),DQSFC(1,LAT), & DUGWD(1,LAT),DVGWD(1,LAT), & SLMSK(1,LAT),SHELEG(1,LAT),TSEA(1,LAT), & SMC(1,LAT, 2 ),STC(1,LAT,1),STC(1,LAT, 2 ), & TG3(1,LAT),ZORL(1,LAT),EP(1,LAT),CLDWRK(1,LAT), & DLWSFC(1,LAT),ULWSFC(1,LAT), & XGRS,GT0,GQ0,PLAMGRS,PPHIGRS,GU0,GV0) ENDIF C C GRID POINT DIAGNOSTICS C CALL KENPUT(LAT,RCL, & SLMSK(1,LAT),PSEXP,TG3(1,LAT),SHELEG(1,LAT),RADSL,DLWSF1, & TSEA(1,LAT),QSS,PLANTR(1,LAT),GFLX,ZORL(1,LAT),CD,CDQ, & RNET,HFLX,STSOIL, & CANOPY(1,LAT),DRAIN,SMSOIL,RUNOF,CLD1D, & U10M(1,LAT),V10M(1,LAT),T2M(1,LAT),Q2M(1,LAT), & HPBL(1,LAT),GAMT,GAMQ, & DQSFC1,DTSFC1,DUSFC1,DVSFC1, & DUSFCG,DVSFCG, & RAINC,RAINL, & GU0(1,1),GV0(1,1), & GT0(1,1),GQ0(1,1), & HSW,HLW(1,1,LAT),VVEL, & SNOWMT,SNOWEV,SNOWFL) C DO 4901 J=1, 384 PWAT(J,LAT)=0. 4901 CONTINUE DO 490 K=1, 28 DO 490 J=1, 384 GT0(J,K)=GT0(J,K)*(1.+FV*GQ0(J,K)) PWAT(J,LAT)=PWAT(J,LAT)+DEL(K)*GQ0(J,K) 490 CONTINUE DO 4902 J=1, 384 PWAT(J,LAT)=PWAT(J,LAT)*PSEXP(J)*(1.E3/ 9.8000E+0 ) 4902 CONTINUE C C QUASI-PRESSURE SURFACE HORIZONTAL DIFFUSION CORRECTION FOR T AND Q C CALL GRIDIFF(DELTIM,SL,PSLAP,GT0,GQ0) C RETURN END FUNCTION ISMAX(LEN,F,INC) C DIMENSION F(LEN) C C FIND INDEX OF THE FIRST OCCURENCE OF MAX C RMAX=F(1) DO I=1,LEN,INC IF(F(I).GE.RMAX) RMAX=F(I) ENDDO DO I=1,LEN,INC IF(F(I).EQ.RMAX) THEN ISMAX=I RETURN ENDIF ENDDO RETURN END FUNCTION ISMIN(LEN,F,INC) C DIMENSION F(LEN) C C FIND INDEX OF THE FIRST OCCURENCE OF MIN C RMIN=F(1) DO I=1,LEN,INC IF(F(I).LE.RMIN) RMIN=F(I) ENDDO DO I=1,LEN,INC IF(F(I).EQ.RMIN) THEN ISMIN=I RETURN ENDIF ENDDO RETURN END SUBROUTINE GETRAD(N,UGM,VGM,SFCNSW,SFCDLW,CZMN,SDEC,CDEC,SLAG, 1 SWH,HLW) DIMENSION * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * CZMN( 384 , 47 ), * UGM( 384 , 28 , 47 ), * VGM( 384 , 28 , 47 ) C.... SDEC=0. E 0 REWIND N READ(N)UGM,VGM,SFCNSW,SFCDLW,CZMN,SDEC,CDEC,SLAG REWIND N PRINT 100,SDEC,CDEC,SLAG 100 FORMAT(1H ,'SDEC,CDEC, SLAG IN GETRAD=',3E12.3) CALL ROW1NS(SFCNSW) CALL ROW1NS(SFCDLW) CALL ROWSNS(UGM,SWH) CALL ROWSNS(VGM,HLW) C RETURN END CFPP$ NOCONCUR R SUBROUTINE GFIDIU(DG,TG,ZG,UG,VG,RQG,DPHI,DLAM, 1 RCL,DEL,RDEL2,CI,P1,P2,H1,H2,TOV,SPDMAX, 2 DTDF,DTDL,DRDF,DRDL,DUDL,DVDL,DUDF,DVDF, 2 DQDT,DTDT,DRDT,DUDT,DVDT) C C INPUT VARIABLES C DIMENSION 1 DG( 386 , 28 ),TG( 386 , 28 ), ZG( 386 , 28 ), 2 UG( 386 , 28 ),VG( 386 , 28 ),RQG( 386 , 28 , 1 ), 3 DPHI( 386 ),DLAM( 386 ) C DIMENSION 1 DTDF( 386 , 28 ),DTDL( 386 , 28 ), 1 DRDF( 386 , 28 , 1 ),DRDL( 386 , 28 , 1 ), 1 DUDL( 386 , 28 ),DVDL( 386 , 28 ), 1 DUDF( 386 , 28 ),DVDF( 386 , 28 ) C OUTPUT VARIABLES C DIMENSION SPDMAX( 28 ), 1 DUDT( 386 , 28 ),DVDT( 386 , 28 ), 1 DTDT( 386 , 28 ),DRDT( 386 , 28 , 1 ), 1 DQDT( 386 ) C C CONSTANT ARRAYS C DIMENSION 1 DEL( 28 ),RDEL2( 28 ), 2 CI( 29 ),TOV( 28 ), 3 P1( 28 ),P2( 28 ),H1( 28 ),H2( 28 ) C C LOCAL VARIABLES C DIMENSION 1 CG ( 386 , 28 ), DB( 386 , 28 ),CB( 386 , 28 ), 2 DOT( 386 , 29 ),DUP( 386 , 28 ),DVP( 386 , 28 ), 3 DUM( 386 , 28 ),DVM( 386 , 28 ), EK( 386 , 28 ), 4 RMU( 28 ),RNU( 28 ),RHO( 28 ),SI( 29 ), 5 X1( 28 ), X2( 28 ), X3( 28 ),X4( 28 ) C RK= 2.8705E+2 / 1.0046E+3 SINRA=SQRT(1.-1./RCL) FNOR=2.* 7.2921E-5 *SINRA FSOU=-FNOR SINRA=SINRA/ 6.3712E+6 C SI(1)=1.0 DO 4 K=1, 28 SI(K+1)=SI(K)-DEL(K) 4 CONTINUE C DO 1 K=1, 27 RHO(K)=ALOG(SI(K)/SI(K+1)) 1 CONTINUE RHO( 28 )=0. C DO 2 K=1, 28 RMU(K)=1.-SI(K+1)*RHO(K)/DEL(K) 2 CONTINUE C DO 3 K=1, 27 RNU(K+1)=-1.+SI(K)*RHO(K)/DEL(K) 3 CONTINUE RNU(1)=0. C DO 20 K=1, 28 X1(K)=RMU(K)*(1.-RK*RNU(K))/(RMU(K)+RNU(K)) X2(K)=1.-X1(K) X3(K)=(1.+RK*RMU(K))/(1.-RK*RNU(K)) X4(K)=1./X3(K) 20 CONTINUE C DO 1234 K=1, 28 SPDMAX(K)=0. 1234 CONTINUE RCL2=.5 E 0*RCL C DO 140 K=1, 28 DO 140 J=1, 384 EK(J,K)=(UG(J,K)*UG(J,K)+VG(J,K)*VG(J,K))*RCL 140 CONTINUE C DO 10 K=1, 28 DO 10 J=1, 384 IF (EK(J,K) .GT. SPDMAX(K)) SPDMAX(K)=EK(J,K) 10 CONTINUE C C COMPUTE C=V(TRUE)*DEL(LN(PS)).DIVIDE BY COS FOR DEL, COS FOR V C DO 150 J=1, 384 DPHI(J)=DPHI(J)*RCL DLAM(J)=DLAM(J)*RCL 150 CONTINUE DO 180 K=1, 28 DO 180 J=1, 384 CG(J,K)=UG(J,K)*DLAM(J)+VG(J,K)*DPHI(J) 180 CONTINUE C DO 190 J=1, 384 DB(J,1)=DEL(1)*DG(J,1) CB(J,1)=DEL(1)*CG(J,1) 190 CONTINUE DO 210 K=1, 27 DO 210 J=1, 384 DB(J,K+1)=DB(J,K)+DEL(K+1)*DG(J,K+1) CB(J,K+1)=CB(J,K)+DEL(K+1)*CG(J,K+1) 210 CONTINUE C C STORE INTEGRAL OF CG IN DLAX C DO 220 J=1, 384 DQDT(J)= -CB(J, 28 ) 220 CONTINUE C C SIGMA DOT COMPUTED ONLY AT INTERIOR INTERFACES. C DO 230 J=1, 384 DOT(J,1)=0. E 0 DVM(J,1)=0. E 0 DUM(J,1)=0. E 0 DOT(J, 29 )=0. E 0 DVP(J, 28 )=0. E 0 DUP(J, 28 )=0. E 0 230 CONTINUE C DO 240 K=1, 27 DO 240 J=1, 384 DOT(J,K+1)=DOT(J,K)+ 1 DEL(K)*(DB(J, 28 )+CB(J, 28 )- 2 DG(J,K)-CG(J,K)) 240 CONTINUE C C C DO 260 K=1, 27 DO 260 J=1, 384 DVP(J,K )=VG(J,K+1)-VG(J,K) DUP(J,K )=UG(J,K+1)-UG(J,K) DVM(J,K+1)=VG(J,K+1)-VG(J,K) DUM(J,K+1)=UG(J,K+1)-UG(J,K) 260 CONTINUE DO J=1, 384 DPHI(J)=DPHI(J)/RCL DLAM(J)=DLAM(J)/RCL ENDDO DO K=1, 28 DO J=1, 384 DUDT(J,K)=-UG(J,K)*DUDL(J,K)-VG(J,K)*DUDF(J,K) 1 -RDEL2(K)*(DOT(J,K+1)*DUP(J,K)+DOT(J,K)*DUM(J,K)) 2 - 2.8705E+2 *TG(J,K)*DLAM(J) C DVDT(J,K)=-UG(J,K)*DVDL(J,K)-VG(J,K)*DVDF(J,K) 1 -RDEL2(K)*(DOT(J,K+1)*DVP(J,K)+DOT(J,K)*DVM(J,K)) 2 - 2.8705E+2 *TG(J,K)*DPHI(J) ENDDO ENDDO C DO K=1, 28 DO J=1, 192 DUDT(J,K)=DUDT(J,K)+VG(J,K)*FNOR DUDT(J+ 192 ,K)=DUDT(J+ 192 ,K)+VG(J+ 192 ,K)*FSOU DVDT(J,K)=DVDT(J,K)-UG(J,K)*FNOR 1 -SINRA*EK(J,K) DVDT(J+ 192 ,K)=DVDT(J+ 192 ,K)-UG(J+ 192 ,K)*FSOU 1 +SINRA*EK(J+ 192 ,K) ENDDO ENDDO DO K=1, 28 DO J=1, 384 DUDT(J,K)=DUDT(J,K)*RCL DVDT(J,K)=DVDT(J,K)*RCL ENDDO ENDDO C C DO 280 K=1, 27 DO 280 J=1, 384 CECMWF: DUP(J,K )=TG(J,K+1)+TOV(K+1)-TG(J,K)-TOV(K)+2.*RK*RNU(K+1)* .(TG(J,K)+TOV(K)) CECMWF: DUM(J,K+1)=TG(J,K+1)+TOV(K+1)-TG(J,K)-TOV(K)+2.*RK*RMU(K+1)* .(TG(J,K+1)+TOV(K+1)) 280 CONTINUE C C DO K=1, 28 DO J=1, 384 C DTDT(J,K)= DTDT(J,K)=-UG(J,K)*DTDL(J,K)-VG(J,K)*DTDF(J,K) 1 -RDEL2(K)*(DOT(J,K+1)*DUP(J,K)+DOT(J,K)*DUM(J,K)) ENDDO ENDDO C DO K=1, 28 DO J=1, 384 DTDT(J,K)=DTDT(J,K) 1 +RK*(TOV(K)+TG(J,K))*(CG(J,K)-CB(J, 28 )-DB(J, 28 )) ENDDO ENDDO C DO 330 N=1, 1 DO 300 K=1, 27 DO 300 J=1, 384 DUP(J,K )=RQG(J,K+1,N)-RQG(J,K,N) DUM(J,K+1)=RQG(J,K+1,N)-RQG(J,K,N) 300 CONTINUE DO 310 J=1, 384 DUP(J, 28 )=0. E 0 310 CONTINUE DO 320 K=1, 28 DO 320 J=1, 384 DRDT(J,K,N)=-UG(J,K)*DRDL(J,K,N)-VG(J,K)*DRDF(J,K,N) 1 -RDEL2(K)*(DOT(J,K+1)*DUP(J,K)+DOT(J,K)*DUM(J,K)) 320 CONTINUE 330 CONTINUE C RETURN END SUBROUTINE GLATS(LGGHAF,COLRAD,WGT,WGTCS,RCS2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GLATS COMPUTES LOCATION OF GAUSSIAN LATITUDES. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-05 C C ABSTRACT: COMPUTES THE LOCATION OF THE GAUSSIAN LATITUDES FOR THE C INPUT LGGHAF. THE LATITUDES ARE DETERMINED BY FINDING C THE ZEROS OF THE LEGENDRE POLYNOMIALS. C C PROGRAM HISTORY LOG: C 88-04-05 JOSEPH SELA C C USAGE: CALL GLATS (LGGHAF, COLRAD, WGT, WGTCS, RCS2) C INPUT ARGUMENT LIST: C LGGHAF - NUMBER OF GAUSSIAN LATITUDES IN A HEMISPHERE. C C OUTPUT ARGUMENT LIST: C COLRAD - ARRAY OF COLATITUDE OF GAUSSIAN LATITUDES C IN NORTHERN HEMISPHERE. C WGT - ARRAY OF WEIGHTS AT EACH GAUSSIAN LATITUDE C REQUIRED FOR GAUSSIAN QUADRATURE. C WGTCS - ARRAY OF GAUSSIAN WEIGHT/SIN OF COLATITUDE SQUARED. C RCS2 - ARRAY OF RECIPROCAL OF SIN OF COLATITUDE SQUARED. C C OUTPUT FILES: C OUTPUT - PRINTOUT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ CCCC HALF PRECISION COLRAD,WGT,WGTCS,RCS2 REAL COLRAD,WGT,WGTCS,RCS2 DIMENSION COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ) DIMENSION RCS2( 47 ) EPS=1.E-12 C PRINT 101 C101 FORMAT ('0 I COLAT COLRAD WGT', 12X, 'WGTCS', CCCC 1 10X, 'ITER RES') SI = 1.0 L2=2*LGGHAF RL2=L2 SCALE = 2.0/(RL2*RL2) K1=L2-1 PI = ATAN(SI)*4.E+00 DRADZ = PI / 360. RAD = 0.0 DO 1000 K=1,LGGHAF ITER=0 DRAD=DRADZ 1 CALL POLY(L2,RAD,P2) 2 P1 =P2 ITER=ITER+1 RAD=RAD+DRAD CALL POLY(L2,RAD,P2) IF(SIGN(SI,P1).EQ.SIGN(SI,P2)) GO TO 2 IF(DRAD.LT.EPS)GO TO 3 RAD=RAD-DRAD DRAD = DRAD * 0.25 GO TO 1 3 CONTINUE COLRAD(K)=RAD PHI = RAD * 180 / PI CALL POLY(K1,RAD,P1) X = COS(RAD) W = SCALE * (1.0 - X*X)/ (P1*P1) WGT(K) = W SN = SIN(RAD) W=W/(SN*SN) WGTCS(K) = W RC=1./(SN*SN) RCS2(K) = RC CALL POLY(L2,RAD,P1) C PRINT 102,K,PHI,COLRAD(K),WGT(K),WGTCS(K),ITER,P1 C102 FORMAT(1H ,I2,2X,F6.2,2X,F10.7,2X,E13.7,2X,E13.7,2X,I4,2X,D13.7) 1000 CONTINUE PRINT 100,LGGHAF 100 FORMAT(1H ,'SHALOM FROM 0.0 E 0 GLATS FOR ',I3) RETURN END SUBROUTINE POLY(N,RAD,P) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: POLY EVALUATES LEGENDRE POLYNOMIAL. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-01 C C ABSTRACT: EVALUATES THE UNNORMALIZED LEGENDRE POLYNOMIAL C OF SPECIFIED DEGREE AT A GIVEN COLATITUDE USING A STANDARD C RECURSION FORMULA. REAL ARITHMETIC IS USED. C C PROGRAM HISTORY LOG: C 88-04-01 JOSEPH SELA C C USAGE: CALL POLY (N, RAD, P) C INPUT ARGUMENT LIST: C N - DEGREE OF LEGENDRE POLYNOMIAL. C RAD - REAL COLATITUDE IN RADIANS. C C OUTPUT ARGUMENT LIST: C P - REAL VALUE OF LEGENDRE POLYNOMIAL. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ X = COS(RAD) Y1 = 1.0 Y2=X DO 1 I=2,N G=X*Y2 Y3=G-Y1+G-(G-Y1)/FLOAT(I) Y1=Y2 Y2=Y3 1 CONTINUE P=Y3 RETURN END SUBROUTINE GLOOPA C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GLOOP COMPUTES DYNAMIC NON-LINEAR TENDENCY TERMS C OF TEMP. DIV. LN(PS) C COMPUTES PREDICTED VALUES OF VORTICITY AND MOISTURE C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-05-13 C C ABSTRACT: C PROGRAM STARTS WITH SPECTRAL COEFFICIENTS TEMP. C OF VORTICITY, DIVERGENCE, SPECIFIC HUMIDITY, AND C LN((PSFC). CONVERTS THEM TO THE GAUSSIAN GRID AT EACH C LATITUDE AND CALLS FIDI, FOR THE NORTHERN AND SOUTHERN C HEMISPHERES AT THE SAME TIME. AFTER RETURN FROM FIDI C SR. COMPLETES CALCULATION OF TENDENCIES OF TEMP. DIV. AND LNPS. C SPECIFIC HUMIDITY, AND VORTICITY ARE PREDICTED BY SR. SIGVOR C ALL INPUT/OUTPUT IS VIA COMMONS. C C PROGRAM HISTORY LOG: C 91-03-06 JOSEPH SELA C C USAGE: CALL GLOOPA C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C C$$$ C.... C................................................................. C................BEGIN TWOLOOP(COMFIBM)........................ C.... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.................SOF TWOLOOP(COMFIBM)........................ C................................................................ PARAMETER(NCPUS= 1 ) C...SOF INCLUDE.......................................... COMMON/COMDHC/SPDLAT( 28 , 47 ) C... C................................................................. C SYN(1, 0* 28 +0* 28 +1, LAN) ZE C SYN(1, 1* 28 +0* 28 +1, LAN) DI C SYN(1, 2* 28 +0* 28 +1, LAN) TE C SYN(1, 3* 28 +0* 28 +1, LAN) RQ C SYN(1, 3* 28 +1* 28 +1, LAN) DPDLAM C SYN(1, 3* 28 +1* 28 +2, LAN) DPDPHI C SYN(1, 3* 28 +1* 28 +3, LAN) ULN C SYN(1, 4* 28 +1* 28 +3, LAN) VLN C................................................................. C DYN(1, 0* 28 +0* 28 +1, LAN) D(T)/D(PHI) C DYN(1, 1* 28 +0* 28 +1, LAN) D(RQ)/D(PHI) C DYN(1, 1* 28 +1* 28 +1, LAN) D(T)/D(LAM) C DYN(1, 2* 28 +1* 28 +1, LAN) D(RQ)/D(LAM) C DYN(1, 2* 28 +2* 28 +1, LAN) D(U)/D(LAM) C DYN(1, 3* 28 +2* 28 +1, LAN) D(V)/D(LAM) C DYN(1, 4* 28 +2* 28 +1, LAN) D(U)/D(PHI) C DYN(1, 5* 28 +2* 28 +1, LAN) D(V)/D(PHI) C................................................................. C ANL(1, 0* 28 +0* 28 +1, LAN) X DVDT C ANL(1, 1* 28 +0* 28 +1, LAN) Y DTDT C ANL(1, 2* 28 +0* 28 +1, LAN) RT DRDT C ANL(1, 2* 28 +1* 28 +1, LAN) Z DQDT C ANL(1, 2* 28 +1* 28 +2, LAN) W DUDT C................................................................. PARAMETER(LOTS =5* 28 +1* 28 +2,LOTST=2* 28 +1, & KSZ =0* 28 +0* 28 +1, & KSD =1* 28 +0* 28 +1, & KST =2* 28 +0* 28 +1, & KSR =3* 28 +0* 28 +1, & KSPLAM =3* 28 +1* 28 +1, & KSPPHI =3* 28 +1* 28 +2,KSTB=3* 28 +1* 28 +2, & KSU =3* 28 +1* 28 +3, & KSV =4* 28 +1* 28 +3) PARAMETER(LOTD =6* 28 +2* 28 +0, & KDTPHI =0* 28 +0* 28 +1, & KDRPHI =1* 28 +0* 28 +1, & KDTLAM =1* 28 +1* 28 +1, & KDRLAM =2* 28 +1* 28 +1, & KDULAM =2* 28 +2* 28 +1, & KDVLAM =3* 28 +2* 28 +1, & KDUPHI =4* 28 +2* 28 +1, & KDVPHI =5* 28 +2* 28 +1) PARAMETER(LOTA =3* 28 +1* 28 +1,LOTAT=2* 28 , & KAV =0* 28 +0* 28 +1, & KAT =1* 28 +0* 28 +1, & KAR =2* 28 +0* 28 +1, & KAP =2* 28 +1* 28 +1, & KAU =2* 28 +1* 28 +2) C... DIMENSION 1 QTT( 4032 ,NCPUS),QVV( 4158 ,NCPUS),QDD( 4032 ,NCPUS), 2 SYN( 386 ,LOTS,NCPUS),SYNTOP(2, 63 ,LOTST), 3 DYN( 386 ,LOTD,NCPUS), 4 ANL( 386 ,LOTA,NCPUS),ANLTOP(2, 63 ,LOTAT), 5 FLP(2, 63 ,LOTA,NCPUS),FLM(2, 63 ,LOTA,NCPUS) C C................................................................. C CALL DELLNP(Q,DPDPHI,SYNTOP(1,1,1),DPDLAM) C CALL DZUVLE(DI,ZE,ULN,VLN,SYNTOP(1,1,2),SYNTOP(1,1, 28 +2)) C C-CRA ANLTOP=0. DO N=1,2 DO J=1, 63 DO L=1,LOTAT ANLTOP(N,J,L)=0.0 ENDDO ENDDO ENDDO C$DOACROSS SHARE(W,X,Y,RT),LOCAL(J,K) CMIC$ DO ALL CMIC$1 SHARED(W,X,Y,RT) CMIC$1 PRIVATE(J,K) DO K=1, 28 DO J=1, 4032 W(J,K)=0. E 0 X(J,K)=0.0 Y(J,K)=0. E 0 ENDDO ENDDO DO K=1, 28 DO J=1, 4032 RT(J,K)=0. E 0 ENDDO ENDDO C DO J=1, 4032 Z(J)=0. E 0 ENDDO C COMPUTE LATITUDE BAND LIMITS LAST=MOD( 47 ,NCPUS) NGGS=( 47 -LAST)/NCPUS IF(LAST.NE.0)NGGS=NGGS+1 INCLAT=NCPUS LAT1=1-NCPUS LAT2=0 LATDON=0 CC DO 10000 NGG=1,NGGS C-CRA DYN=0. DO N=1,NCPUS DO L=1,LOTD DO J=1, 386 DYN(J,L,N)=0. ENDDO ENDDO ENDDO IF((NGG.EQ.NGGS).AND.(LAST.NE.0)) INCLAT=LAST LAT1=LAT1+NCPUS LAT2=LAT2+INCLAT CC LATPRT=2 C C LAT LOOP C C FIRST LAT LOOP C$DOACROSS SHARE(SYNTOP,SYN,QTT,QVV,LAT1,LAT2,LATDON,COLRAD, C$& Q,DPDLAM,DPDPHI,ULN,VLN,DI,TE,ZE,RQ), C$& LOCAL(LAT,LAN) CMIC$ DO ALL CMIC$1 SHARED(SYNTOP,SYN,QTT,QVV,LAT1,LAT2,LATDON,COLRAD) CMIC$1 SHARED(Q,DPDLAM,DPDPHI,ULN,VLN,DI,TE,ZE,RQ) CMIC$1 PRIVATE(LAT,LAN) C DO 1000 LAT=LAT1,LAT2 LAN=LAT-LATDON C CALL PLN2I(QTT(1,LAN),QVV(1,LAN),COLRAD,LAT) C CALL SUMS2I(ZE,SYN(1,1,LAN),QTT(1,LAN),LOTS) C CALL SUMTOP(SYN(1,KSTB,LAN),SYNTOP,QVV(1,LAN),LOTST, 192 , 192 /2) 1000 CONTINUE C C COMPUTE MERID. DERIVS. OF TEMP. AND MOISTURE USING QDD. C C$DOACROSS SHARE(DYN,QDD,WGT,RCS2,EPSI,QTT,QVV,LAT1,LAT2,LATDON, C$& TE,RQ),LOCAL(LAT,LAN) CMIC$ DO ALL CMIC$1 SHARED(DYN,QDD,WGT) CMIC$1 SHARED(RCS2,EPSI) CMIC$1 SHARED(QTT,QVV,LAT1,LAT2,LATDON) CMIC$1 SHARED(TE,RQ) CMIC$1 PRIVATE(LAT,LAN) C DO 1100 LAT=LAT1,LAT2 LAN=LAT-LATDON C CALL GOZRIN(QTT(1,LAN),QVV(1,LAN),QDD(1,LAN), 1 EPSI,LAT,RCS2,WGT) C CALL SUMS2I(TE,DYN(1,1,LAN),QDD(1,LAN), 28 + 28 ) C 1100 CONTINUE C$DOACROSS SHARE(DYN,RCS2,SYN,ANL,LAT1,LAT2,LATDON,SPDLAT, C$& DEL,RDEL2,CI,P1,P2,H1,H2,TOV), C$& LOCAL(LAT,LAN,J,K) CMIC$ DO ALL CMIC$1 SHARED(DYN,RCS2) CMIC$1 SHARED(SYN,ANL,LAT1,LAT2,LATDON,SPDLAT) CMIC$1 SHARED(DEL,RDEL2,CI,P1,P2,H1,H2,TOV) CMIC$1 PRIVATE(LAT,LAN,J,K) C DO 2000 LAT=LAT1,LAT2 LAN=LAT-LATDON C C CALCULATE T RQ U V ZONAL DERIVS. BY MULTIPLICATION WITH I*L C CALL DERIVS(SYN(1,1,LAN),DYN(1,1,LAN),RCS2(LAT)) C DO K=1, 28 DO J=1, 384 SYN(J,KST-1+K,LAN)=SYN(J,KST-1+K,LAN)-TOV(K) ENDDO ENDDO C CALL GFIDIU(SYN(1,KSD,LAN),SYN(1,KST,LAN), 1 SYN(1,KSZ,LAN),SYN(1,KSU,LAN), 1 SYN(1,KSV,LAN),SYN(1,KSR,LAN), 1 SYN(1,KSPPHI,LAN),SYN(1,KSPLAM,LAN), 1 RCS2(LAT),DEL,RDEL2,CI,P1,P2,H1,H2,TOV,SPDLAT(1,LAT), 1 DYN(1,KDTPHI,LAN),DYN(1,KDTLAM,LAN), 1 DYN(1,KDRPHI,LAN),DYN(1,KDRLAM,LAN), 1 DYN(1,KDULAM,LAN),DYN(1,KDVLAM,LAN), 1 DYN(1,KDUPHI,LAN),DYN(1,KDVPHI,LAN), 1 ANL(1,KAP,LAN),ANL(1,KAT,LAN), 1 ANL(1,KAR,LAN),ANL(1,KAU,LAN), 1 ANL(1,KAV,LAN)) C CALL FTI_LONF(ANL(1,1,LAN),ANL(1,1,LAN),2*LOTA,-1) C C C AT THIS POINT ARRAYS HOLD TWO LATITUDES OF FOURIER COEFS C 2000 CONTINUE C C C$DOACROSS SHARE(LATDON,LAT1,LAT2,ANL,FLP,FLM), C$& LOCAL(LAT,LAN) CMIC$ DO ALL CMIC$1 SHARED(LATDON,LAT1,LAT2) CMIC$1 SHARED(ANL,FLP,FLM) CMIC$1 PRIVATE(LAT,LAN) C DO 2500 LAT=LAT1,LAT2 LAN=LAT-LATDON C CALL FLPFLM(FLP(1,1,1,LAN),FLM(1,1,1,LAN), 1 ANL(1,1,LAN)) 2500 CONTINUE C C DO 3000 LAT=LAT1,LAT2 LAN=LAT-LATDON C C C-CRA CALL FL2I(FLP(1,1,1,LAN),FLM(1,1,1,LAN),X,QTT(1,LAN),LOTA) CALL FL2IP(FLP(1,1,1,LAN),FLM(1,1,1,LAN),X,QTT(1,LAN),LOTA) C CALL UVSUMS(FLP(1,1,KAU,LAN),FLM(1,1,KAU,LAN), 1 FLP(1,1,KAV,LAN),FLM(1,1,KAV,LAN), 2 ANLTOP(1,1,1),ANLTOP(1,1, 28 +1), 3 QVV(1,LAN), 28 ,WGT(LAT)) C C PRINT 4324, LAN, LAT, LATDON C4324 FORMAT(/ 1H ,'RMS TENDEN GLOOPAV INSIDE LOOP 3000 ', C 1'COL2=U COL4=V LAN=',I3, ' LAT=',I3, ' LATDON=',I3 ) C CALL RMSGT(Z ,X ,Y ,W ,DEL,RT ) C C 3000 CONTINUE LATDON=LATDON+(LAT2-LAT1+1) C...................................................... C...................................................... 10000 CONTINUE C...................................................... C C$DOACROSS SHARE(SPDMAX,SPDLAT),LOCAL(K,LAT) CMIC$ DO ALL CMIC$1 SHARED(SPDMAX,SPDLAT) CMIC$1 PRIVATE(K,LAT) DO K=1, 28 SPDMAX(K) = 0.0 DO LAT=1, 47 SPDMAX(K)=MAX(SPDMAX(K),SPDLAT(K,LAT)) ENDDO SPDMAX(K)=SQRT(SPDMAX(K)) ENDDO C...................................................... C C C INPUT : W=D(U)/D(T) X=D(V)/D(T) C OUTPUT: ULN=D(DI)/D(T) VLN=D(ZE)/D(T) C CALL UVTODZ(W ,X ,ULN,VLN,ANLTOP(1,1,1),ANLTOP(1,1, 28 +1)) C..................................................... C SUBTRACT OFF LINEAR DEPENDENCE ON DIVERGENCE DO 850 K=1, 28 DO 840 J=1, 28 DO 830 I=1, 4032 Y(I,K)=Y(I,K)-BM(K,J)*DI(I,J) 830 CONTINUE 840 CONTINUE 850 CONTINUE C MOVE DIV TENDENCY INTO X AND ADD TOPOG. CONTRIB. C INTEGRATE VORTICITY AMD MOISTURE IN TIME C REMEMBER ULN IS OLD X C REMEMBER VLN IS OLD W C DO K=1, 28 DO I=1, 4032 X(I,K)=ULN(I,K)+GZ(I) W(I,K)=ZEM(I,K)+2.*DELTIM*VLN(I,K) ENDDO ENDDO DO K=1, 28 DO I=1, 4032 RT(I,K)= RM(I,K)+2.*DELTIM* RT(I,K) ENDDO ENDDO DO K=1, 28 W(1,K)=0. E 0 W(2,K)=0. E 0 ENDDO C PRINT 100,(SPDMAX(K),K=1, 28 ) 100 FORMAT(' SPDMX(01:10)=',10F5.0,:/' SPDMX(11:20)=',10F5.0, & :/' SPDMX(21:30)=',10F5.0,:/' SPDMX(31:40)=',10F5.0, & :/' SPDMX(41:50)=',10F5.0,:/' SPDMX(51:60)=',10F5.0, & :/' SPDMX(61:70)=',10F5.0,:/' SPDMX(71:80)=',10F5.0, & :/' SPDMX(81:90)=',10F5.0,:/' SPDMX(91:00)=',10F5.0) C RETURN END SUBROUTINE GLOOPB C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) PARAMETER(NCPUS= 1 ) DIMENSION GDA(NWGDA,KDGDA,NCPUS) C................................................................. C SYN(1, 0* 28 +0* 28 +1, LAN) DPDLAM C SYN(1, 0* 28 +0* 28 +2, LAN) DPDPHI C SYN(1, 0* 28 +0* 28 +3, LAN) ULN C SYN(1, 1* 28 +0* 28 +3, LAN) VLN C SYN(1, 2* 28 +0* 28 +3, LAN) Q C SYN(1, 2* 28 +0* 28 +4, LAN) X C SYN(1, 3* 28 +0* 28 +4, LAN) Y C SYN(1, 4* 28 +0* 28 +4, LAN) RT C SYN(1, 4* 28 +1* 28 +4, LAN) PLAP :NEW DEL ONLY C................................................................. C ANL(1, 0* 28 +0* 28 +1, LAN) ZE DUDT C ANL(1, 1* 28 +0* 28 +1, LAN) DI DVDT C ANL(1, 2* 28 +0* 28 +1, LAN) TE DTDT C ANL(1, 3* 28 +0* 28 +1, LAN) RQ DRDT C................................................................. C-NDL PARAMETER(LOTS =4* 28 +1* 28 +3,LOTST=2* 28 +1, PARAMETER(LOTS =4* 28 +1* 28 +4,LOTST=2* 28 +1, & KSPLAM =0* 28 +0* 28 +1, & KSPPHI =0* 28 +0* 28 +2,KSTB=0* 28 +0* 28 +2, & KSU =0* 28 +0* 28 +3, & KSV =1* 28 +0* 28 +3, & KSP =2* 28 +0* 28 +3, & KSD =2* 28 +0* 28 +4, & KST =3* 28 +0* 28 +4, & KSR =4* 28 +0* 28 +4) C-NDL PARAMETER(KSPLAP =4* 28 +1* 28 +4) C PARAMETER(LOTA =3* 28 +1* 28 +0,LOTAT=2* 28 , & KAU =0* 28 +0* 28 +1, & KAV =1* 28 +0* 28 +1, & KAT =2* 28 +0* 28 +1, & KAR =3* 28 +0* 28 +1) C DIMENSION 2 QTT( 4032 ,NCPUS),QVV( 4158 ,NCPUS), X FPL(2, 63 ,LOTA,NCPUS),FML(2, 63 ,LOTA,NCPUS), 1 SYN( 386 ,LOTS,NCPUS),ANL( 386 ,LOTA,NCPUS) DIMENSION SYNTOP(2, 63 ,LOTST) DIMENSION ANLTOP(2, 63 ,LOTAT) DIMENSION TGMXL(NCPUS),IGMXL(NCPUS),KGMXL(NCPUS) DIMENSION TGMNL(NCPUS),IGMNL(NCPUS),KGMNL(NCPUS) C-RAS LOGICAL RAS C-RAS PARAMETER (RAS=.TRUE.) C-RAS PARAMETER (LMX= 28 ) C-RAS PARAMETER (CP= 1.0046E+3 , ALHL= 2.5000E+6 , GRAV= 9.8000E+0 , RGA C 1S= 2.8705E+2 ) C-RAS DIMENSION SIG(LMX+1), PRJ(LMX+1), PRH(LMX), FPK(LMX), HPK(LMX) C-RAS*, SGB(LMX), ODS(LMX), RASAL(LMX), PRNS(LMX/2) C-RAS*, RANNUM(LMX) C DIMENSION ZTEMP( 4033 ) C................................................................. LOGICAL LADJ PARAMETER(LADJ=.TRUE.) C C-RAS PARAMETER(NSPHYS=1) C C-RAS IF (RAS) CALL SETRAS(LMX, SI, SL, DEL, CP, RGAS, DELTIM C-RAS*, NSPHYS, FHOUR C-RAS*, SIG, SGB, PRH, PRJ, HPK, FPK, ODS, PRNS C-RAS*, RASAL, LM, KRMIN, KRMAX, NSTRP C-RAS*, NCRND, RANNUM, AFAC, UFAC) C CALL DELLNP(Q,DPDPHI,SYNTOP,DPDLAM) CALL DZUVLE(X,W,ULN,VLN,SYNTOP(1,1,2),SYNTOP(1,1, 28 +2)) C DO I=1, 4033 ZTEMP(I)=Z(I) ENDDO CALL DELDFSP(Q,Z) C C PRINT *,'Q=' C PRINT *,Q C C PRINT *,'Z=' C PRINT *,Z C DO 33 K=1, 28 DO 220 J=1, 4032 ZE(J,K)=0. E 0 DI(J,K)=0. E 0 TE(J,K)=0. E 0 220 CONTINUE 33 CONTINUE DO 221 K=1, 28 DO 221 J=1, 4032 RQ(J,K)=0. E 0 221 CONTINUE C-CRA ANLTOP=0. DO N=1,2 DO J=1, 63 DO L=1,LOTAT ANLTOP(N,J,L)=0.0 ENDDO ENDDO ENDDO TGMX=-1.E20 TGMN= 1.E20 C C COMPUTE LATITUDE BAND LIMITS LAST=MOD( 47 ,NCPUS) NGGS=( 47 -LAST)/NCPUS IF(LAST.NE.0)NGGS=NGGS+1 INCLAT=NCPUS LAT1=1-NCPUS LAT2=0 LATDON=0 DO 10000 NGG=1,NGGS IF((NGG.EQ.NGGS).AND.(LAST.NE.0)) INCLAT=LAST LAT1=LAT1+NCPUS LAT2=LAT2+INCLAT DO 200 LAT=LAT1,LAT2 LAN=LAT-LATDON CALL GETDIA(LAT,NWGDA*KDGDA,GDA(1,1,LAN)) 200 CONTINUE CALL SYNDIA DO N=1,NCPUS TGMXL(N)=TGMX TGMNL(N)=TGMN ENDDO C FIRST LAT LOOP C$DOACROSS SHARE(SYN,ANL,QTT,QVV,LAT1,LAT2,LATDON, C$& OLRAB,DPDLAM,SYNTOP, C$& TGMXL,IGMXL,KGMXL,TGMNL,IGMNL,KGMNL, C$& GDA,RAS,LMX,CP,ALHL,GRAV,RGAS, C$& SIG, SGB, PRH, PRJ, HPK, FPK, ODS, PRNS, C$& RASAL, LM, KRMIN, KRMAX, NSTRP, C$& NCRND, RANNUM, AFAC, UFAC), C$& LOCAL(DUMMY,LAT,LAN) CMIC$ DO ALL CMIC$1 SHARED(SYN,ANL,QTT,QVV,LAT1,LAT2,LATDON) CMIC$1 SHARED(COLRAB,DPDLAM,SYNTOP) CMIC$1 SHARED(TGMXL,IGMXL,KGMXL,TGMNL,IGMNL,KGMNL) CMIC$1 SHARED(GDA,RAS,LMX,CP,ALHL,GRAV,RGAS) CMIC$1 SHARED(SIG, SGB, PRH, PRJ, HPK, FPK, ODS, PRNS) CMIC$1 SHARED(RASAL, LM, KRMIN, KRMAX, NSTRP) CMIC$1 SHARED(NCRND, RANNUM, AFAC, UFAC) CMIC$1 PRIVATE(DUMMY,LAT,LAN) CMIC$1 AUTOSCOPE C C LAT LOOP C DO 1000 LAT =LAT1,LAT2 LAN=LAT-LATDON C C.... SINLAB= COS(COLRAB(LAT)) C CALL PLN2I(QTT(1,LAN),QVV(1,LAN),COLRAB,LAT) C CALL SUMS2I(DPDLAM,SYN(1,1,LAN),QTT(1,LAN),LOTS) C CALL SUMTOP(SYN(1,KSTB,LAN),SYNTOP,QVV(1,LAN),LOTST, 192 , 192 /2) C CALL FTI_LONB(SYN(1,1,LAN),DUMMY,2*LOTS,1) C c write(0,'(i4,1pe12.4)') (k,syn(1,k,lan),k=1,lots) c write(0,'("sp ",1pe12.4)') syn(1,ksp,lan) c write(0,'("splam ",1pe12.4)') syn(1,ksplam,lan) c write(0,'("spphi ",1pe12.4)') syn(1,kspphi,lan) c write(0,'("sd ",1pe12.4)') syn(1,ksd,lan) c write(0,'("su ",1pe12.4)') syn(1,ksu,lan) c write(0,'("sv ",1pe12.4)') syn(1,ksv,lan) c write(0,'("st ",1pe12.4)') syn(1,kst,lan) c write(0,'("sr ",1pe12.4)') syn(1,ksr,lan) c write(*,'("qlap ",1pe12.4)') syn(1,ksplap,lan) C CALL GBPHYS( X SYN(1,KSPLAM,LAN),SYN(1,KSPPHI,LAN), X SYN(1,KSU,LAN),SYN(1,KSV,LAN),SYN(1,KSP,LAN), X SYN(1,KST,LAN),SYN(1,KSR,LAN),SYN(1,KSD,LAN), X SYN(1,KSPLAP,LAN), X ANL(1,KAT,LAN),ANL(1,KAR,LAN),ANL(1,KAU,LAN),ANL(1,KAV,LAN), X TGMXL(LAN),IGMXL(LAN),KGMXL(LAN), X TGMNL(LAN),IGMNL(LAN),KGMNL(LAN), X GDA(1,1,LAN), C-RASX RAS,LMX,CP,ALHL,GRAV,RGAS, C-RASX SIG, SGB, PRH, PRJ, HPK, FPK, ODS, PRNS, C-RASX RASAL, LM, KRMIN, KRMAX, NSTRP, C-RASX NCRND, RANNUM, AFAC, UFAC, X LAT) C CALL FTI_LONB(ANL(1,1,LAN),ANL(1,1,LAN),2*LOTA,-1) C 1000 CONTINUE DO 2200 LAT=LAT1,LAT2 LAN=LAT-LATDON CALL PUTDIA(LAT,NWGDA*KDGDA,GDA(1,1,LAN)) 2200 CONTINUE C C$DOACROSS SHARE(QTT,QVV,WGB,LATDON,LAT1,LAT2, C$& ANL,FPL,FML,RCS2), C$& LOCAL(LAT,LAN,I,J,K) CMIC$ DO ALL CMIC$1 SHARED(QTT,QVV,WGB,LATDON,LAT1,LAT2) CMIC$1 SHARED(ANL,FPL,FML,RCS2) CMIC$1 PRIVATE(LAT,LAN,I,J,K) C DO 2500 LAT=LAT1,LAT2 LAN=LAT-LATDON C DO 714 I=1, 4032 QTT(I,LAN)=QTT(I,LAN)*WGB(LAT) 714 CONTINUE C DO K=1, 28 DO J=1, 384 ANL(J,KAU-1+K,LAN)=ANL(J,KAU-1+K,LAN)*RCS2(LAT) ANL(J,KAV-1+K,LAN)=ANL(J,KAV-1+K,LAN)*RCS2(LAT) ENDDO ENDDO C CALL FBPFBM(FPL(1,1,1,LAN),FML(1,1,1,LAN),ANL(1,1,LAN)) C 2500 CONTINUE C C LATITUDE LOOP DO 3000 LAT=LAT1,LAT2 LAN=LAT-LATDON C C-CRA CALL FL2I(FPL(1,1,1,LAN),FML(1,1,1,LAN),ZE,QTT(1,LAN),LOTA) CALL FL2IP(FPL(1,1,1,LAN),FML(1,1,1,LAN),ZE,QTT(1,LAN),LOTA) C C ZE=U CORRECTION C DI=V CORRECTION C TE=T CORRECTION C RQ=R CORRECTION C C NEW CALL: NOTE QVV IS NOT MULTIPLIED BY WGT YET C CALL UVSUMS(FPL(1,1,KAU,LAN),FML(1,1,KAU,LAN), 1 FPL(1,1,KAV,LAN),FML(1,1,KAV,LAN), 2 ANLTOP(1,1,1),ANLTOP(1,1, 28 +1), 3 QVV(1,LAN), 28 ,WGT(LAT)) C IF(TGMXL(LAN).GT.TGMX) THEN TGMX=TGMXL(LAN) IGMX=IGMXL(LAN) KGMX=KGMXL(LAN) JGMX=LAT ELSE IF(TGMNL(LAN).LT.TGMN) THEN TGMN=TGMNL(LAN) IGMN=IGMNL(LAN) KGMN=KGMNL(LAN) JGMN=LAT ENDIF 3000 CONTINUE LATDON=LATDON+(LAT2-LAT1+1) 10000 CONTINUE C CALL UVTODZ(ZE,DI,ULN,VLN,ANLTOP(1,1,1),ANLTOP(1,1, 28 +1)) C DO I=1, 4033 Z(I)=ZTEMP(I) ENDDO C IF(LADJ) THEN DO J=1, 4032 Z(J)=0.0 ENDDO ENDIF C C$DOACROSS SHARE(Z,Q,DEL,RQ,RT,DI,X,ZE,W,TE,Y,ULN,VLN), C$& LOCAL(J,K) CMIC$ DO ALL CMIC$1 SHARED(Z,Q,DEL,RQ,RT,DI,X,ZE,W,TE,Y,ULN,VLN) CMIC$1 PRIVATE(J,K) C DO K=1, 28 DO J=1, 4032 IF(LADJ) THEN DI(J,K)=ULN(J,K)-X(J,K) TE(J,K)=TE(J,K)-Y(J,K) ELSE X(J,K)=ULN(J,K) Y(J,K)=TE(J,K) ENDIF W(J,K)=VLN(J,K) ENDDO ENDDO C DO K=1, 28 DO J=1, 4032 RT(J,K)=RQ(J,K) ENDDO ENDDO IF(LADJ) THEN CALL IMPADJ(X,Y,Q,DI,TE,Z,ULN,VLN) ENDIF C PRINT '(" GLOOPB T RANGE ",2(4X,F6.1," @I,K,LAT ",3I4))', & TGMX,IGMX,KGMX,JGMX,TGMN,IGMN,KGMN,JGMN CALL SYNDIA C RETURN END SUBROUTINE GLOOPP(Q,AVPRS0) C C SURFACE PRESSURE CORRECTION FOR LONG INTEGRATIONS C C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C DIMENSION Q( 4033 ) DIMENSION PRS( 386 , 47 ) DIMENSION QNEW( 4033 ) DIMENSION FLP(2, 63 , 47 ),FLM(2, 63 , 47 ) DIMENSION QTT( 4032 , 47 ),QVV( 4158 , 47 ) C C LOOP TO FIND AVERAGE PRESSURE C AVPRS=0. SUMWGT=0. C DO LAT=1, 47 CALL PLN2I(QTT(1,LAT),QVV(1,LAT),COLRAD,LAT) CALL SUMS2I(Q,PRS(1,LAT),QTT(1,LAT),1) ENDDO C DO LAT=1, 47 CALL FTI_LONF(PRS(1,LAT),DUMMY,2,1) DO I=1, 384 PRS(I,LAT)=EXP(PRS(I,LAT)) ENDDO ENDDO C DO LAT=1, 47 DO I=1, 384 AVPRS=AVPRS+PRS(I,LAT)*WGT(LAT) SUMWGT=SUMWGT+WGT(LAT) ENDDO ENDDO AVPRS=AVPRS/SUMWGT PRINT *,'SUMWGT=',SUMWGT,' AVPRS=',AVPRS,' AVPRS0=',AVPRS0 C C PRESSURE CORRECTION LOOP C IF(AVPRS0.GT.0) THEN C DO J=1, 4032 QNEW(J)=0.E0 ENDDO C DO LAT=1, 47 DO I=1, 384 PRS(I,LAT)=LOG(PRS(I,LAT)-AVPRS+AVPRS0) ENDDO CALL FTI_LONF(PRS(1,LAT),PRS(1,LAT),2,-1) ENDDO C DO LAT=1, 47 CALL FLPFLM2(FLP(1,1,LAT),FLM(1,1,LAT),PRS(1,LAT),1) ENDDO C DO LAT=1, 47 DO I=1, 4032 QTT(I,LAT)=QTT(I,LAT)*WGT(LAT) ENDDO CALL FL2I(FLP(1,1,LAT),FLM(1,1,LAT),QNEW,QTT(1,LAT),1) ENDDO C DO J=1, 4032 Q(J)=QNEW(J) ENDDO C ELSE C AVPRS0=AVPRS C ENDIF C RETURN END SUBROUTINE GLOOPR CFPP$ EXPAND(ZNLACM,ACCDIA) C.. ************************************************************ C.. * ADDED ACCUMULATION OF CLDS AND CONVECTIVE CLOUD IN DG3 * C.. * K.A.C SEPT 1994 * C.. * F3D ADDED FOR CLOUDS..MI NEW CODE=F94/SOURCE2/DIAGNEW * C.. * B KATZ + K.A.C OCT 1994 * C.. * CHANGED H,M,L CALCULATION IN CLDJMS (REMOVED FACV) * C.. * AND ADDED PROPER TOTAL CLOUD CALCULATION * C.. * CHANGED AVECLD CALC IN CLDIAG (USED CLDARY) AND * C.. * USED TOTAL CLOUD CALCULATED IN CLDJMS * C.. * CHANGED KENPTS TO STORE TOTAL CLOUD AND ALL LYRS * C.. * OF CLOUD...... * C.. * K.A.C. NOV94 * C.. * INTERPOLATE O3 PROFILE TO EACH GRIDPOINT, IE USE * C.. * PROPER SURFACE PRESSURE * C.. * K.A.C. DEC94 * C.. * FIX PL1 FOR OPERATIONS, WHERE DGZ IS ON AND DG3 IS OFF, * C.. * ....NOTE DG IS ON IF EITHER DGZ OR DG3 IS ON * C.. * K.A.C. JAN94 * C.. ************************************************************ C C UPDATES MADE TO ADD OCEANIC STRATUS AND TO FIX CONV CLOUD.. C TO GLOOPR - IVV(2),IBL ARE SET=1.... C TO GLOOPR - SET MIN Q TO 1.E-10,RATHER THAN 1.E-6 C TO ANTICIPATE AVOIDING CLD CREATION C IN EXTREMELY DRY,COLD (WINTER) REGIONS C WHERE 1.E-6 COULD IMPLY HI VALU OF RH C TO CLDJMS - MULTITUDE OF CHANGES C UPDATES MADE TO FIX THE H2D,H3D FILES...KAC AUG 90... C UPDATES MADE TO GLOOPR - CALL WRTH2D BEFORE WRTRAD (SO CTOP OK) C TO GLOOPR - SEND WORK ARRAY TO WRTH3D C TO WRTH3D - TO WRITE PROPER LAYERS OF HEAT.. C (IN WRTRAD) C UPDATES MADE TO ADD GRID POINT DIAGNOSTICS ..K.A.C...SEP 91 C TO GLOOPR - C UPDATES MADE TO FIX SW APPROX ..K.A.C...NOV 91 C TO COSZMN C UPDATES MADE TO PASS AND RECEIVE SIB DATA ..K.A.C...MAR 92 C TO GLOOPR - C UPDATES MADE TO FIX SW RAD DIAGNOSTICS ..K.A.C...JUN 92 C PROPER DIURNAL WEIGHTING C TO GLOOPR AND COSZMN C UPDATES MADE TO CALCULATE CLEAR-SKY "ON-THE-FLY" KAC AUG 92 C TO GLOOPR,RADFS,FST,SPA,LWR,SWR C ...FOR CLOUD FORCING.... CYH93... C UPDATES MADE FOR THE COMPLETELY NEW CLOUD ROUTINE (CLDJMS),USE C FLAG IVVA TO CONTROL VERTICAL VELOCITY ADJ. C FOR LOW CLD (=0: WITHOUT, =1: WITH) CYH94 NOT USE FLAG IEMIS TO CONTROL CLD EMISS. SCHEME CYH94 NOT (=0: ORIG. SCHEME, =1: TEMP. DEP. SCHEME.) C USE FLAG INVR TO CONTROL LAPSE RATE INVERSION C TYPE OF CLD (=0: WITHOUT, =1: WITH) C TO GLOOPR AND RADFS ...Y.H. ...DEC92 C UPDATES MADE TO CALL CLD OPTICAL PROPERTY ROUTINE (CLDPRP), C TO GIVE CLD EMISSIVITY, OPTICAL DEPTH, LAYER C REFLECTANCE AND TRANSMITANCE C TO GLOOPR AND RADFS ...Y.H. ...FEB93 CYH94 CLDPRP CALLED FROM RADFS... Y.H. ...FEB94 CTUNE C UPDATES MADE TO ALLOW TUNED CLD-RH DATA TO BE USED..CTUNE C TO GLOOPR AND CLDJMS ..K.A.C...DEC 92 C SPATIAL INTERPOLATION OF TABLES ........MAY93 C USE ONLY 1 SET OF TUNING TABLES FOR ALL FCST HRS, C THE TUNING OF THE 24HR FCST .....JAN94 C OLD CODE USED 6 TABLES..SEE CKC94 .....FEB94 C SINCE TUNING DONE FOR H,M,L CLD, VERTICALLY C BLEND THE RELATIONS AT OLD HML BDRIES..JAN94 C UPDATES MADE TO CHANGE DEFINITION OF H,M,L DOMAINS.. C TO GLOOPR,GCLJMS,CLDJMS, CLDPRP K.A.C...DEC92 + AUG93 CYH94 TO GLOOPR, CLDJMS, CLDPRP K.A.C...JAN94 CYH94 TO CLDJMS.. CVTOP = KCVT (NOT KCVT+1) CYH94 AND TO ISTRAT=1 PART...NEW STRATUS + CYH94 ..NO CLOUD BELOW LLYRL.. K.A.C...MAR94 CYH94 ..CHANGES TO CLDPRP.........Y.H...MAR94 CTUNE CYH93... CHL95 MODIFIED TO ALLOW MORE FREQUENT COMPUTATION OF SHORTWAVE FLUX CHL95 ASSUME THAT DTSWAV <= DTLWAV!!!!!.....H.-L. PAN JUL95 C CYH95 MODIFIED TO USE M.D.CHOU'S SW RADIATION SCHEME, WITH C WMO AEROSOLS DISTRIBUTIONS, AND B.P.BREIGLEB'S SURFACE C ALBEDO SCHEME. ..............Y.H...SEP95 C TO GLOOPR - CALL INSUR2 ... INPUT SURFACE ALBEDO AND C AEROSOLS DATA C CALL ALBAER ... COMPUTE ALBEDO AND AEROSOLS C DISTRIBUTIONS C CALL GRLWSW,GAEROS ... DATA INITIAL CYH95 ... ENDYH C--- PARAMETER(NCPUS= 1 ,NCPUS1=NCPUS+1) PARAMETER(NCLDB1=NCPUS* 384 / 384 +1) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) CTUNE CKC94 PARAMETER (MCLD=3,NSEAL=2,NBIN=100,NLON=2,NLAT=4,IDA=6) PARAMETER (MCLD=3,NSEAL=2,NBIN=100,NLON=2,NLAT=4) CTUNE C PARAMETER (NOZON=48) CO3 parameter (loz=17) common /sbuv/ psnasa(loz),o3nasa(37,loz) dimension pstr(loz) CO3 PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) C DIAGNOSTIC INDEXES AND FLAGS PARAMETER(KDGDA=13) PARAMETER(KDTLARG=1,KDTCONV=2,KDQCONV=3,KDTSHAL=4,KDQSHAL=5, & KDTVRDF=6,KDUVRDF=7,KDVVRDF=8,KDQVRDF=9, & KDTHSW=10,KDTHLW=11,KDTCLD=12,KDTCCV=13) CHARACTER*8 CNMGDA COMMON /COMGDC/ CNMGDA(KDGDA) PARAMETER(NTGDA=92) PARAMETER(NWGDA=(( 384 * 28 -1)/512+1)*512) PARAMETER(NRGDA= 47 ) COMMON /COMGDA/ IPUGDA(KDGDA),IBMGDA(KDGDA) CCDGM COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) COMMON /COMGDD/ GDD(NWGDA*KDGDA*NRGDA) DIMENSION GDA(NWGDA,KDGDA,NCLDB1) C... C... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.... C.... SAVE SOLC,RSIN1,RCOS1,RCOS2 C.... COMMON /VERCON/ ROTSIN,ROTCOS,SEADRY,SL1KAP,C1,C2,RLRV,SL100K C.... INTEGER SEASON C COMMON /DIUCON/ C 2 SEASON, FCSTDA, C 3 JTYME(5), DAZ(12), JDNMC, C 4 FJDNMC, TSLAG, RLAG, C 5 TIMIN, TPI, HPI, C 6 YEAR, DAY, DHR, C 7 IXXXX COMMON /DIUCON/ 2 SEASON, LSEASON, FCSTDA, 3 JTYME(5), LFTYPE, DAZ(12), JDNMC, LJDNMC, 4 FJDNMC, TSLAG, RLAG, 5 TIMIN, TPI, HPI, 6 YEAR, DAY, DHR, 7 IXXXX, LIXXXX C COMMON /TABLES/ SC C.... DIMENSION COSZER( 384 , 47 ),COSZDG( 384 , 47 ) C... COMMON /SHRCOM/ * COLRAR( 47 ),WGR( 47 ),WGRCS( 47 ),RRS2( 47 ) COMMON /SHRCOM/ SINLAR( 384 , 47 ),COSLAR( 384 , 47 ) C... C............................................................. COMMON /SHRCOM/ ALBEDR( 384 , 47 ),SLMSKR( 384 , 47 ) COMMON /SHRCOM/ RLON( 384 , 47 ),RLAT( 384 , 47 ) C.... DIMENSION AVECLD( 28 , 94 ),CLDL(4, 94 ),CLDSIG( 28 ,18) DIMENSION AVECV(3, 94 ),ZONHT( 28 , 94 ) C.... COMMON /SHRCOM/ ILEFTR( 384 ),IRGHTR( 384 ),WGRLON( 384 ) COMMON /SHRCOM/ INRLAT( 47 ),WGRLAT( 47 ) C.... COMMON /SHRCOM/ JSNO,JMAXP1,IPOINT,JPOINT, 1 RADDT,IUNCO2,KCCO2,ITIMSW,ITIMLW COMMON /SHRCOM/ IYR,IMON,IDAY,IZTIM,IHR,LGTH,IND,KDIMP1,KYEAR, 1 JD,FJD,IFJD,LIFJD,DLT, MUNTH,IM,ID,IYEAR COMMON /SHRCOM/ ALVBR( 384 , 47 ),ALNBR( 384 , 47 ), 1 ALVDR( 384 , 47 ),ALNDR( 384 , 47 ), 2 PAERR( 384 ,5, 47 ) COMMON /SHRCOM/ R1,ALF,XMIN,RUNRAD LOGICAL RUNRAD CSIB .. ALBEDOES FROM SIB PARAMETERIZATION...NEEDED FOR SW RAD C .. THEY NEED TO BE INTERPOLATED FROM FCST TO RADIATION GRID C-SIB COMMON/SIB/ ALVBF( 384 , 47 ),ALNBF( 384 , 47 ), C-SIB1 ALVDF( 384 , 47 ),ALNDF( 384 , 47 ) C...... DOWNWARD SW FLUXES FROM SW RAD..FOR SIB PARAMETERIZATION C .. THEY NEED TO BE INTERPOLATED FROM RADIATION TO FCST GRID C-SIB COMMON/SIB/ GDFVBF( 384 , 47 ),GDFNBF( 384 , 47 ), C-SIB1 GDFVDF( 384 , 47 ),GDFNDF( 384 , 47 ) C.... CLDARY CONTAINS MULTI LAYERS OF CLOUD DIMENSION CLDTOT( 384 , 28 ,NCPUS1),CLDCNV( 384 , 28 ,NCPUS1) DIMENSION SFCP( 384 ,NCPUS1) DIMENSION CLDT( 384 , 28 ,NCLDB1),CLCV( 384 , 28 ,NCLDB1) DIMENSION SFCPR( 384 ,NCLDB1) DIMENSION WORKF( 384 ,10),IWORKF( 384 ) C................................................................. C SYN(1, 0* 28 +0* 28 +1, LAN) DI C SYN(1, 1* 28 +0* 28 +1, LAN) TE C SYN(1, 2* 28 +0* 28 +1, LAN) RQ C SYN(1, 2* 28 +1* 28 +1, LAN) DPDLAM C SYN(1, 2* 28 +1* 28 +2, LAN) DPDPHI C SYN(1, 2* 28 +1* 28 +3, LAN) ULN C SYN(1, 3* 28 +1* 28 +3, LAN) VLN C SYN(1, 4* 28 +1* 28 +3, LAN) Q C................................................................. PARAMETER(LOTS =4* 28 +1* 28 +3,LOTST=2* 28 +1, & KSD =0* 28 +0* 28 +1, & KST =1* 28 +0* 28 +1, & KSR =2* 28 +0* 28 +1, & KSPLAM =2* 28 +1* 28 +1, & KSPPHI =2* 28 +1* 28 +2,KSTB=2* 28 +1* 28 +2, & KSU =2* 28 +1* 28 +3, & KSV =3* 28 +1* 28 +3, & KSP =4* 28 +1* 28 +3) C... DIMENSION 1 SYN( 386 ,LOTS,NCPUS),SYNTOP(2, 63 ,LOTST) C.... PARAMETER(LWORKR=(20/LOTS*20+LOTS/20*LOTS)/(20/LOTS+LOTS/20)) DIMENSION WORKR( 384 ,LWORKR) DIMENSION IWORKR( 384 ) DIMENSION QTT( 4032 ,NCPUS),QVV( 4158 ,NCPUS), 2 TSEAR( 384 ,NCPUS),SHELGR( 384 ,NCPUS), 3 CVR( 384 ,NCPUS),CVTR( 384 ,NCPUS), 4 CVBR( 384 ,NCPUS), 5 OZONEA( 384 , 28 ,NCPUS),ALBDOA( 384 ,NCPUS), 7 CLDARY( 384 , 28 ,NCPUS),CLDSA( 384 ,4,NCPUS), 8 MTOPA( 384 ,3,NCPUS),MBOTA( 384 ,3,NCPUS), 9 SWHR( 384 , 28 ,NCPUS1),HLWR( 384 , 28 ,NCPUS1), A SFNSWR( 384 ,NCPUS1),SFDLWR( 384 ,NCPUS1) B ,TSFLWR( 384 ,NCPUS1) C ADDED BY BOB GRUMBINE FOR SEA ICE ALBEDO ALGORITHM C , TGR( 384 , NCPUS) C COMMON /SHRCOM/ ALVBR( 384 , 47 ),ALNBR( 384 , 47 ), C 1 ALVDR( 384 , 47 ),ALNDR( 384 , 47 ), C 2 PAERR( 384 ,5, 47 ) COMMON /ALAER1/ ALVSF( 384 , 47 ,4),ALNSF( 384 , 47 ,4), 1 ALVWF( 384 , 47 ,4),ALNWF( 384 , 47 ,4), 2 FACSF( 384 , 47 ),FACWF( 384 , 47 ), 3 PAERF( 384 , 47 ,5) DIMENSION GDFVBR( 384 ,NCPUS1),GDFNBR( 384 ,NCPUS1), 3 GDFVDR( 384 ,NCPUS1),GDFNDR( 384 ,NCPUS1) C...... DOWNWARD SW FLUXES FROM SW RAD..FOR SIB PARAMETERIZATION C .. SAVED FOR H2D FILE.... COMMON/SIBSW/ DFVBR( 384 , 47 ),DFNBR( 384 , 47 ), 1 DFVDR( 384 , 47 ),DFNDR( 384 , 47 ) CYH95 ... NALAER IS THE UNIT NO. FOR INPUTING SURFACE ALBEDO AND AEROSOL C DATA FROM SUBR 'INSUR2'. THIS IS A QUICK FIX, AND MAY BE MOVED C TO SUBRO 'FIXIO' OR OTHER PLACE LATER. C KALB IS THE CONTROL FLAG FOR SW SFC ALBEDO SCHEME SAVE NALAER,KALB,jo3, CTUNE1 JCAP,LEVS,CRH,RAD1ST,DTHR,HDTHR,DTLMOD,DTSMOD 1 JCAP,LEVS, RAD1ST,DTHR,HDTHR,DTLMOD,DTSMOD,DTLW, 2 RHCLT,RHCL,FHR1,FHR2,FHRTAB,FHR1ST,IDTLN,IDTLS,DLON,ISTRAT CTUNE C... ARRAY ADDED FOR RH-CL CALCULATION C INDICES FOR LON,LAT,CLD TYPE(L,M,H), LAND/SEA RESPECTIVELY C NLON=1-2, FOR EASTERN AND WESTERN HEMISPHERES C NLAT=1-4, FOR 60N-30N,30N-EQU,EQU-30S,30S-60S C LAND/SEA=1-2 FOR LAND(AND SEAICE),SEA C.... RHCLT WILL CONTAIN ALL TIME LEVELS OF CLD-RH TABLES DIMENSION RHCL (NBIN,NLON,NLAT,MCLD,NSEAL) C... FHRTAB = VALID FCST HRS FOR CLD-RH TABLES CKC94 DATA FHRTAB / 0. E 0,12. E 0,36. E 0,60. E 0,84. E 0,108. E 0 / CKAC ISTRAT = 0, USE CRH BELOW (DEFAULT), = 1 USE TUNED RHCLD C... ISTRAT = 0, CALCULATE CRH IN CLDJMS, = 1 USE TUNED RHCLD DATA ISTRAT / 1 / CTUNE LOGICAL RAD1ST DATA NALAER,KALB /49,1/ DATA JCAP/ 62 /,LEVS/ 28 / DATA RAD1ST/.TRUE./ C C-LFC KDAPRX=0 C.... IF(RAD1ST) THEN RUNRAD = .TRUE. CTUNE CKC94 GET CLD-RH RELATIONS IN TABULAR FORM FOR DAY 0-5 CKC94 CALL CRHTAB(RHCLT,IER) C.... GET CLD-RH RELATIONS IN TABULAR FORM FOR DAY 1 CALL CRHTAB(RHCL ,IER) IF (IER.LT.0) THEN ISTRAT = 0 PRINT 1113 1113 FORMAT(1H ,'===>TUNING TABLES NOT AVAILABLE..USE DEFAULT CRH') END IF PRINT 1114,ISTRAT 1114 FORMAT(1H ,'..FOR DIAGNOSED CLDS....ISTRAT = ',I4) FHR1ST = FHOUR - DTSWAV C.... COMPUTE LONGITUDE REGIONS (DATELINE) IDTLN = 192 /2 IDTLS = 384 *3/4 DLON = 360. / 192 CTUNE KCCO2 = 0 IUNCO2 = 15 IPOINT = 0 JPOINT = 0 CALL GLATS ( 47 , COLRAR, WGR, WGRCS, RRS2) DO 1 J=1, 47 SINLAJ=COS(COLRAR(J)) COSLAJ=SQRT(1. E 0 - SINLAJ*SINLAJ) DO 1 I=1, 192 SINLAR(I,J)= SINLAJ COSLAR(I,J)= COSLAJ SINLAR(I+ 192 ,J)=-SINLAJ COSLAR(I+ 192 ,J)= COSLAJ 1 CONTINUE CALL GFT_LONR CYH93... THE FOLLOWING CODE HAS BEEN REWRITTEN.... CALL GCLJMS(SI) CYH95 ..CALL GRADFS(SL,KCCO2,IUNCO2) CYH95 ... ADD NEW DATA INITIALIZATION ROUTINES FOR RAD AND AEROSOLS CALL GRLWSW(SL,IUNCO2) CALL GAEROS(SI,SL) C.... C... SPECIFY QUANTITIES NEEDED FOR CALL TO NEW RADFS ..KAC JUL89 KDIMP1 = 28 + 1 JMAXP1 = 94 +1 C... SPECIFY THE LATITUDE WHERE PERMANENT SNOW RESIDES POLEWARD... C JSNO=LATITUDE CLOSEST TO 70 DEG N-INDICATING EXTENT OF PERM C SNOW COVER. WILL CHANGE AS A FCN. OF LATITUDE STRUCTURE. JSNO=( 94 +1)/9 C.... GET INTERVAL (HRS) BETWEEN SHORT-WAVE RADIATION CALLS..... RADDT = 3600. E 0 * DTSWAV DTLW = 3600. * DTLWAV CALL LONLAT(RLON, 384 ,RLAT,COLRAR, 47 ) C===> PREPARE THREE SFC FIELDS AS INPUT TO RADIATION CALCULATIONS C ALSO PREPARE 3 CONVECTIVE ARRAYS FOR INPUT TO CLD SCHEME.. C NEED TO INTERPOLATE FROM FCST MODEL GRID TO RADIATION GRID. CALL BILWGT(COLRAB, 47 , 384 ,COLRAR, 47 , 384 , 1 INRLAT,WGRLAT,ILEFTR,IRGHTR,WGRLON) C===> PREPARE HEATING RATES AND FLUXES FOR SHIPMENT TO FCST MODEL C NEED TO INTERPOLATE FROM RADIATION GRID TO FCST MODEL GRID. CALL BILWGT(COLRAR, 47 , 384 ,COLRAB, 47 , 384 , 1 INSLAT,WGTLAT,ILEFT,IRGHT,WGTLON) IF(INISTP.EQ.0) THEN DO 50 IV=1,26 DO 50 J=1, 47 DO 50 I=1, 384 FLUXR(I,J,IV) = 0. E 0 50 CONTINUE DO 60 J=1, 47 DO 60 I=1, 384 CVAVG(I,J) = 0. E 0 60 CONTINUE CSIB DO 1877 J=1, 47 DO 1877 I=1, 384 DFVBR (I,J) = 0. E 0 DFNBR (I,J) = 0. E 0 DFVDR (I,J) = 0. E 0 DFNDR (I,J) = 0. E 0 1877 CONTINUE CSIB ENDIF CALL INSURF(ALBEDO,SLMSK, 1 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,ALBEDR,SLMSKR) CYH95 ... 'INSUR2' READ IN SURFACE ALBEDO AND AEROSOLS DATA CALL INSUR2(NALAER,ALVSF,ALNSF,ALVWF,ALNWF,FACSF,FACWF,PAERF) RAD1ST = .FALSE. ENDIF DTHR = DELTIM / 3600.0 HDTHR = 0.5 * DTHR ITIMSW = 0 ITIMLW = 0 DTSMOD = AMOD(SOLHR,DTSWAV) IF(INISTP.NE.0 .OR. DTSMOD.LT.HDTHR .OR. DTSMOD.GE.DTSWAV-HDTHR) 1 ITIMSW = 1 DTLMOD = AMOD(SOLHR,DTLWAV) IF(INISTP.NE.0 .OR. DTLMOD.LT.HDTHR .OR. DTLMOD.GE.DTLWAV-HDTHR) 1 ITIMLW = 1 IF(ITIMSW.EQ.0 .AND. ITIMLW.EQ.0) RETURN IF(.NOT.RUNRAD .AND. INISTP.NE.0) GO TO 20000 CDG3 COMPUTE NUM SEC BETWEEN CALLS TO CLD CODE...FOR DIAGNOSTICS DTACC = MIN(DTSWAV,DTLWAV) DTACC = DTACC*3600. E 0 PRINT 1001, JCAP, LEVS 1001 FORMAT (1H0,'GFDL REDUCED RAD',I2,I2,'G, E TYP, FEB 20 1986') CTUNE CKC94 DO 1117 M=1,NSEAL CKC94 DO 1117 LCC=1,MCLD CKC94 DO 1117 K=1,NLAT CKC94 DO 1117 J=1,NLON CKC94 DO 1117 I=1,NBIN CKC94 RHCL(I,J,K,LCC,M) = RHCLT(I,J,K,LCC,M,6) C1117 CONTINUE C.... ADVANCE THE CLOCK FOR TIME INTERPOLATING THE CLD-RH RELATION CKC94 FHR1ST = FHR1ST + DTSWAV + .1 CKC94 IHR1ST = FHR1ST CKC94 FHR1ST = IHR1ST CKC94 FHLAST = FHRTAB(IDA) CKC94 IF (FHR1ST.LT.FHLAST) THEN C... TIME INTERPOLATE THE CLD-RH RELATION IF .108 HRS C LINEAR INTERPOLATION... C.... DAY 0,1,2,3,4,5 VALID FOR FHR=0,12,36,60,84,108 CKC94 DO 1116 KTIME=2,IDA CKC94 IF (FHR1ST.LT.FHRTAB(KTIME)) THEN CKC94 IC2 = KTIME CKC94 FHR2 = FHRTAB(KTIME) CKC94 GO TO 1111 CKC94 END IF C1116 CONTINUE C1111 CONTINUE CKC94 IC1 = IC2 - 1 CKC94 FHR1 = FHRTAB(IC1) CKC94 PRINT 2007,FHR1,FHR2,FHR1ST C2007 FORMAT(1H ,'..FOR TUNING INTERP, FHR1,FHR2,FHR1ST=',3F6.0) CKC94 DO 1119 M=1,NSEAL CKC94 DO 1119 LCC=1,MCLD CKC94 DO 1119 K=1,NLAT CKC94 DO 1119 J=1,NLON CKC94 DO 1119 I=1,NBIN CKC94 RHCL(I,J,K,LCC,M) = CKC941 (RHCLT(I,J,K,LCC,M,IC2)-RHCLT(I,J,K,LCC,M,IC1))* CKC942 (FHR1ST-FHR1)/(FHR2-FHR1) + RHCLT(I,J,K,LCC,M,IC1) C1119 CONTINUE CKC94 IF (FHR1ST.LE.12. E 0) THEN C.... IF 0-12..USE DAY1 FOR LOW CLOUD..SOME PROBLEM WITH VV OR C TUNING ALGORITHM FOR LOW CLD AT DAY0 WHEN VV USED CKC94 LCC = 1 CKC94 DO 1129 M=1,NSEAL CKC94 DO 1129 K=1,NLAT CKC94 DO 1129 J=1,NLON CKC94 DO 1129 I=1,NBIN CKC94 RHCL(I,J,K,LCC,M) = RHCLT(I,J,K,LCC,M,2) C1129 CONTINUE CKC94 END IF CKC94 END IF CTUNE IF(INISTP.NE.0) THEN DO 70 IV=1,26 DO 70 J=1, 47 DO 70 I=1, 384 FLUXR(I,J,IV) = 0. E 0 70 CONTINUE DO 80 J=1, 47 DO 80 I=1, 384 CVAVG(I,J) = 0. E 0 80 CONTINUE CSIB DO 1888 J=1, 47 DO 1888 I=1, 384 DFVBR (I,J) = 0. E 0 DFNBR (I,J) = 0. E 0 DFVDR (I,J) = 0. E 0 DFNDR (I,J) = 0. E 0 1888 CONTINUE CSIB CALL INSURF(ALBEDO,SLMSK, 1 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,ALBEDR,SLMSKR) CYH95 ... 'INSUR2' READ IN SURFACE ALBEDO AND AEROSOLS DATA CALL INSUR2(NALAER,ALVSF,ALNSF,ALVWF,ALNWF,FACSF,FACWF,PAERF) ENDIF LGTH= 384 * 47 IND=-1 CALL EXTRM1(ALBEDR,LGTH,IND) CALL RMSGT ( Q, DI, TE, ZE,DEL,RQ) C **************************************************************** C... * ASTRONOMY CALCULATIONS-ONCE FOR EACH NEW RADIATION STEP * C **************************************************************** C.. GET 4 DIGIT YEAR FOR JULIAN DAY COMPUTATION IYR = IDATE(4) IMON = IDATE(2) IDAY = IDATE(3) IZTIM = IDATE(1) c IF(IYR.LT.100) THEN c KYEAR = 1900 + IYR c ELSE c KYEAR = IYR c ENDIF c wne if (IYR.lt.45) then KYEAR = 2000 + IYR else if (IYR.le.99) then KYEAR = 1900 + IYR else KYEAR = IYR endif CHOUR=FHOUR+SHOUR/3600. CALL COMPJD(KYEAR,IMON,IDAY,IZTIM,0,JDNMC,FJDNMC) CALL FCSTIM(CHOUR,IMON,IDAY,IZTIM,JDNMC,FJDNMC,RLAG,YEAR, 1 RSIN1,RCOS1,RCOS2,JD,FJD) C..************************** IF(ITIMSW.EQ.1) THEN CALL SOLAR(JD,FJD,R1,DLT,ALF,SLAG,SDEC,CDEC) CYH95 IF(KDAPRX.GE.1) THEN CALL COSZMN(DTSWAV,SOLHR,SINLAR,COSLAR,SDEC,CDEC,SLAG, 1 RLON, 384 , 47 ,COSZER,.TRUE.,COSZDG) C..************************** C... CALCULATE SOLAR INPUT APPROPRIATE FOR DATE C..************************** SOLC=SC/(R1*R1) ENDIF CALL CDATE(JD,FJD,MUNTH,IM,ID,IYEAR,IHR,XMIN) CALL PRTIME(ID,MUNTH,IYEAR,IHR,XMIN,JD,FJD,DLT,ALF,R1,SLAG,SOLC) C **************************************************************** C... * NASA O3 CALCULATIONS-ONCE FOR EACH NEW RADIATION STEP * c... * get new climo from NASA 12-month SBUV data * c.. * if jo3=0 use old gfdl climo, jo3=1 use new nasa climo ozone * C **************************************************************** jo3=0 call o3sbuv(fhour,idate,nozon,o3nasa,pstr,jerr) if (jerr.le.0) then c.. if NASA data file was available (jerr=0), NOT (jerr=1) jo3=1 C===> ... GET NASA PRESSURE IN CB (FLIP VERTICAL COORDINATE) DO 30 N=1,LOZ PSNASA(N) = PSTR(LOZ+1-N)*1. E -1 30 CONTINUE end if print 167 if (jo3.eq.0) print 166 if (jo3.eq.1) print 168 print 167 166 FORMAT(' USING GFDL ZONAL SEASONAL OZONE CLIMO ') 167 FORMAT(' ------ ') 168 FORMAT(' USING NASA ZONAL MONTHLY OZONE CLIMO ') CYH95 ... MOVE THE 2ND 'COSZMN' CALL FROM BOTTOM PLACE TO HERE FOR C ALBEDO AND AEROSOL DATA INTERPOLATIONS IF(ITIMSW.EQ.1) THEN CALL COSZMN(DTSWAV,SOLHR,SINLAB,COSLAB,SDEC,CDEC,SLAG, 1 XLON, 384 , 47 ,COSZEN,.FALSE.,WORKR) C-MK CALL ALBAER(IM,SLMSK,SHELEG,ZORL,COSZEN,TSEA,STC,JSNO, C-MK2 CALL ALBAER(IM,SLMSK,SHELEG,ZORL,COSZEN,TSEA, CALL ALBAER(IM,SLMSK,SHELEG,ZORL,COSZEN,TSEA,HPRIME,JSNO, 1 ALVSF,ALNSF,ALVWF,ALNWF,FACSF,FACWF,PAERF, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,SLMSKR, 3 ALVBR,ALNBR,ALVDR,ALNDR,PAERR) ENDIF C CALL DELLNP(Q,DPDPHI,SYNTOP,DPDLAM) CALL DZUVLE(DI,ZE,ULN,VLN,SYNTOP(1,1,2),SYNTOP(1,1, 28 +2)) C..************************** CC LAST=MOD( 47 ,NCPUS) NGGS=( 47 -LAST)/NCPUS IF(LAST.NE.0)NGGS=NGGS+1 INCLAT=NCPUS LAT1=1-NCPUS LAT2=0 LATDON=0 DO 10000 NGG=1,NGGS IF((NGG.EQ.NGGS).AND.(LAST.NE.0)) INCLAT=LAST LAT1=LAT1+NCPUS LAT2=LAT2+INCLAT IF(NGG.EQ.1) THEN LTWIDL=1 LATRD1=1 ELSE IF(NGG.EQ.2) THEN LTWIDL=MOD(LTWIDL+NCPUS-2,NCPUS1)+1 LATRD1=LAT1-1 ELSE LTWIDL=MOD(LTWIDL+NCPUS-1,NCPUS1)+1 LATRD1=LAT1-1 ENDIF LATIN1=INRLAT(LATRD1)+1 CKZ IF(NGG.EQ.1) LATIN1=1 IF(LATDON.LE.1) LATIN1=1 LATIN2=INRLAT(LAT2) IF(NGG.EQ.NGGS) LATIN2= 47 LATOUT=LATIN2-LATIN1+1 DO 150 LAT=LATIN1,LATIN2 LAN=LAT-LATIN1+1 CALL GETDIA(LAT,NWGDA*KDGDA,GDA(1,1,LAN)) 150 CONTINUE DO 190 LAT=LAT1,LAT2 LAN=LAT-LATDON DO 190 I=1, 384 CVR (I,LAN) = 0.0 E 0 CVBR(I,LAN) = 0.0 E 0 CVTR(I,LAN) = 0.0 E 0 190 CONTINUE C... INTERPOLATE CONVECTIVE CLOUD DATA CALL CVINTF(CV,CVT,CVB, 384 , 47 , 47 , 1 CVR,CVTR,CVBR, 384 ,INCLAT, 47 , 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT, 3 WORKR(1,1),WORKR(1,5),WORKR(1,9),WORKR(1,13), 4 WORKR(1,17),IWORKR,1,1,LAT1) CALL GGINTF(TSEA, 384 , 47 , 47 , 1 TSEAR, 384 ,INCLAT, 47 ,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORKR,1,1,LAT1) CALL GGINTF(SHELEG, 384 , 47 , 47 , 1 SHELGR, 384 ,INCLAT, 47 ,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORKR,1,1,LAT1) C ADDED BY BOB GRUMBINE FOR SEA ICE/SNOW ALBEDO ALGORITHM CALL GGINTF(STC, 384 , 47 , 47 , 1 TGR, 384 ,INCLAT, 47 ,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORKR,1,1,LAT1) CSIB C... INTERPOLATE SIB ALBEDOES......... cmoo ALVBR=-1. cmoo ALVBF=-1. cmoo ALVDR=-1. cmoo ALVDF=-1. C-SIB CALL GGINTF(ALVBF, 384 , 47 , 47 , C-SIB1 ALVBR, 384 ,INCLAT, 47 ,1, C-SIB2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORKR,1,1,LAT1) C-SIB CALL GGINTF(ALNBF, 384 , 47 , 47 , C-SIB1 ALNBR, 384 ,INCLAT, 47 ,1, C-SIB2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORKR,1,1,LAT1) C-SIB CALL GGINTF(ALVDF, 384 , 47 , 47 , C-SIB1 ALVDR, 384 ,INCLAT, 47 ,1, C-SIB2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORKR,1,1,LAT1) C-SIB CALL GGINTF(ALNDF, 384 , 47 , 47 , C-SIB1 ALNDR, 384 ,INCLAT, 47 ,1, C-SIB2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORKR,1,1,LAT1) CSIB IF(NGG.EQ.1) THEN TSMIN=TSEAR(1,1) TSMAX=TSEAR(1,1) SHMIN=SHELGR(1,1) SHMAX=SHELGR(1,1) ENDIF C C LAT LOOP C$DOACROSS SHARE(SYN,LAT1,LAT2,LATDON,COLRAR,RRS2,QTT,QVV,NCPUS1, C$& Q,DPDLAM,DPDPHI,ULN,VLN,DI,TE,RQ, C$& SYNTOP,RLAT,RLON, C$& RHCL,ISTRAT,DLON,IDTLN,IDTLS, C$& JSNO,FJD,DLT,SLAG, C$& KALB,JO3, C$& SHELGR,ALBEDR,SLMSKR,TSEAR,TGR, C$& OZONEA,ALBDOA, C$& CLDARY,CLDSA,MTOPA,MBOTA, C$& CLDTOT,CLDCNV,SFCP, C$& RSIN1,RCOS1,RCOS2, C$& CVR,CVTR,CVBR,AVECLD,CLDL,AVECV), C$& LOCAL(WORKR,LAT,LATCO,LAN,LATRAD) CMIC$ DO ALL CMIC$1 SHARED(SYN,LAT1,LAT2,LATDON,COLRAR,RRS2,QTT,QVV,NCPUS1) CMIC$2 SHARED(Q,DPDLAM,DPDPHI,ULN,VLN,DI,TE,RQ) CMIC$3 SHARED(SYNTOP,RLAT,RLON) CMIC$4 SHARED(RHCL,ISTRAT,DLON,IDTLN,IDTLS) CMIC$5 SHARED(JSNO,FJD,DLT,SLAG) CMIC$6 SHARED(KALB,JO3) CMIC$7 SHARED(SHELGR,ALBEDR,SLMSKR,TSEAR,TGR) CMIC$8 SHARED(OZONEA,ALBDOA) CMIC$9 SHARED(CLDARY,CLDSA,MTOPA,MBOTA) CMIC$A SHARED(CLDTOT,CLDCNV,SFCP) CMIC$B SHARED(RSIN1,RCOS1,RCOS2) CMIC$C SHARED(CVR,CVTR,CVBR,AVECLD,CLDL,AVECV) CMIC$D PRIVATE(WORKR,LAT,LATCO,LAN,LATRAD) C DO 1000 LAT=LAT1,LAT2 LAN=LAT-LATDON LATCO= 94 +1-LAT LATRAD=MOD(LAT-1,NCPUS1)+1 C CALL PLN2I(QTT(1,LAN),QVV(1,LAN),COLRAR,LAT) C CALL SUMS2R(DI,SYN(1,1,LAN),QTT(1,LAN),LOTS) CCC X 192 , 192 /2) C.... CALL SUMTOP(SYN(1,KSTB,LAN),SYNTOP,QVV(1,LAN),LOTST, 192 , 192 /2) C C IF(LAT .EQ. 2) CALL ERREXIT C CALL FTI_LONR (SYN(1,1,LAN),WORKR,2*LOTS,1) C C-DBG print *,'temp from GLOOPR at LAT=',LAT C-DBG call maxmin(SYN(1,KST,LAN), 386 , 28 , 384 , 28 ,1) C-DBG print *,'specific humidity from GLOOPR at LAT=',LAT C-DBG call maxmin(SYN(1,KSR,LAN), 386 , 28 , 384 , 28 ,1) C-DBG print *,'tsea,snow,tg,albd,slmsk from GLOOPR at LAT=',LAT C-DBG call maxmin(TSEAR(1,LAN), 386 ,1, 384 ,1,1) C-DBG call maxmin(SHELGR(1,LAN), 386 ,1, 384 ,1,1) C-DBG call maxmin(TGR(1,LAN), 386 ,1, 384 ,1,1) C-DBG call maxmin(ALBEDR(1,LAT), 386 ,1, 384 ,1,1) C-DBG call maxmin(SLMSKR(1,LAT), 386 ,1, 384 ,1,1) C-DBG C CALL GRRAD1(SYN(1,KSD,LAN),SYN(1,KSPLAM,LAN),SYN(1,KSPPHI,LAN), 1 SYN(1,KSU,LAN),SYN(1,KSV,LAN),SYN(1,KST,LAN), 2 SYN(1,KSR,LAN),SYN(1,KSP,LAN), 3 ALBEDR(1,LAT),SLMSKR(1,LAT), CYH95 ... 4 RLON(1,LAT),RLAT(1,LAT), 5 TSEAR(1,LAN),SHELGR(1,LAN),TGR(1,LAN), 6 CVR(1,LAN),CVTR(1,LAN),CVBR(1,LAN),RHCL, CYH95 ... 7 OZONEA(1,1,LAN),ALBDOA(1,LAN),CLDARY(1,1,LAN), 9 CLDSA(1,1,LAN),MTOPA(1,1,LAN),MBOTA(1,1,LAN), A RRS2,LAT,LATCO,IDTLN,IDTLS,DLON,ISTRAT, CYH95 ... B KALB,JO3,SLAG,RSIN1,RCOS1,RCOS2, C FJD,DLT,JSNO,WORKR,LWORKR, D CLDTOT(1,1,LATRAD),CLDCNV(1,1,LATRAD), E SFCP(1,LATRAD), F AVECV,AVECLD,CLDL) C 1000 CONTINUE C C LAT LOOP C$DOACROSS SHARE(SYN,LAT1,LAT2,LATDON,NCPUS1, C$& KALB,ITIMLW,ITIMSW,RADDT,DTLW, C$& RLAT,COSZER,COSZDG, C$& SHELGR,SLMSKR,TSEAR,TGR, C$& OZONEA,ALBDOA,PAERR, C$& CLDARY,CLDSA,MTOPA,MBOTA, C$& SDEC,SOLC,RSIN1,RCOS1,RCOS2, C$& SFDLWR,SFNSWR,SWHR,HLWR,TSFLWR,ZONHT, C$& ALVBR,ALNBR,ALVDR,ALNDR, C$& GDFVBR,GDFNBR,GDFVDR,GDFNDR), C$& LOCAL(LAT,LATCO,LAN,LATRAD) CMIC$ DO ALL CMIC$1 SHARED(SYN,LAT1,LAT2,LATDON,NCPUS1) CMIC$2 SHARED(KALB,ITIMLW,ITIMSW,RADDT,DTLW) CMIC$3 SHARED(RLAT,COSZER,COSZDG) CMIC$4 SHARED(SHELGR,SLMSKR,TSEAR,TGR) CMIC$5 SHARED(OZONEA,ALBDOA,PAERR) CMIC$6 SHARED(CLDARY,CLDSA,MTOPA,MBOTA) CMIC$7 SHARED(SDEC,SOLC,RSIN1,RCOS1,RCOS2) CMIC$8 SHARED(SFDLWR,SFNSWR,SWHR,HLWR,TSFLWR,ZONHT) CMIC$9 SHARED(ALVBR,ALNBR,ALVDR,ALNDR) CMIC$A SHARED(GDFVBR,GDFNBR,GDFVDR,GDFNDR) CMIC$B PRIVATE(LAT,LATCO,LAN,LATRAD) C $B PRIVATE(LAT,LATCO,LAN,LATRAD,lv,i) C DO 2000 LAT=LAT1,LAT2 LAN=LAT-LATDON LATCO= 94 +1-LAT LATRAD=MOD(LAT-1,NCPUS1)+1 C c do lv=1, 28 c do i=1, 384 c ozonea(i,lv,lan) = syn(i,kso+lv-1,lan) c enddo c enddo c c print *,' calling GRRAD2 for Lat=',LAT CALL GRRAD2(SYN(1,KST,LAN),SYN(1,KSR,LAN),SYN(1,KSP,LAN), CYH95 ... 1 PAERR(1,1,LAT),OZONEA(1,1,LAN),ALBDOA(1,LAN), 2 SLMSKR(1,LAT),COSZER(1,LAT),COSZDG(1,LAT), CYH95 ... 3 RLAT(1,LAT),TSEAR(1,LAN), 4 ALVBR(1,LAT),ALNBR(1,LAT),ALVDR(1,LAT),ALNDR(1,LAT), 5 CLDARY(1,1,LAN),CLDSA(1,1,LAN), 6 MTOPA(1,1,LAN),MBOTA(1,1,LAN), 7 LAT,LATCO,SDEC,SOLC,RSIN1,RCOS1,RCOS2, CYH95 ... 8 RADDT,DTLW,ITIMSW,ITIMLW,KALB, 9 SWHR(1,1,LATRAD),HLWR(1,1,LATRAD),ZONHT, A SFNSWR(1,LATRAD),SFDLWR(1,LATRAD),TSFLWR(1,LATRAD), B GDFVDR(1,LATRAD),GDFNDR(1,LATRAD), C GDFVBR(1,LATRAD),GDFNBR(1,LATRAD)) C 2000 CONTINUE LGTH= 384 *INCLAT IND=1 CALL EXTRM2(NGG,NGGS,TSEAR,TSMIN,TSMAX,SHELGR,SHMIN,SHMAX, 1 LGTH,IND) CDG3 INTERPOLATE TO FORECAST MODEL GRID CDG3 FROM NCPUS1 LATS ON COARSE GRID TO LATOUT LATS ON FINE GRID.. CKZ PROTECTION AGAINST PREMATURE INTERPOLATION FOLLOWS LATDON=LATDON+(LAT2-LAT1+1) IF(LATDON.GT.1) THEN CALL CLINTF(CLDTOT, 384 ,NCPUS1, 47 , 1 CLDT, 384 ,LATOUT, 47 , 28 , 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 3 WORKF(1,1),WORKF(1,5),WORKF(1,9), 4 IWORKF,LTWIDL,LATRD1,LATIN1) CALL CLINTF(CLDCNV, 384 ,NCPUS1, 47 , 1 CLCV, 384 ,LATOUT, 47 , 28 , 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 3 WORKF(1,1),WORKF(1,5),WORKF(1,9), 4 IWORKF,LTWIDL,LATRD1,LATIN1) CALL GGINTF(SFCP, 384 ,NCPUS1, 47 , 1 SFCPR, 384 ,LATOUT, 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, 3 LTWIDL,LATRD1,LATIN1) CDG3 CONVERT TO AMOUNT (*100) CALL SYNDIA C CC$DOACROSS SHARE(CLDT,CLCV,LATIN1,LATOUT, CC$& GDA, CC$& DTACC,SFCPR), CC$& LOCAL(I,K,LAT,LAN) CCMIC$ DO ALL CCMIC$B SHARED(CLDT,CLCV,LATIN1,LATOUT) CCMIC$D SHARED(GDA) CCMIC$G SHARED(DTACC,SFCPR) CCMIC$C PRIVATE(I,K,LAT,LAN) CDG3... DO 1039 LAT=1,LATOUT DO 351 K=1, 28 DO 351 I=1, 384 IF (CLDT(I,K,LAT).LT.0. E 0) THEN CLDT(I,K,LAT) = 0. E 0 ELSE IF (CLDT(I,K,LAT).GT.1. E 0) THEN CLDT(I,K,LAT) = 100. E 0 ELSE CLDT(I,K,LAT) = CLDT(I,K,LAT) * 100. E 0 END IF 351 CONTINUE DO 352 K=1, 28 DO 352 I=1, 384 IF (CLCV(I,K,LAT).LT.0. E 0) THEN CLCV(I,K,LAT) = 0. E 0 ELSE IF (CLCV(I,K,LAT).GT.1. E 0) THEN CLCV(I,K,LAT) = 100. E 0 ELSE CLCV(I,K,LAT) = CLCV(I,K,LAT) * 100. E 0 END IF 352 CONTINUE LAN = LATIN1 + LAT - 1 CALL ZNLACM( 384 ,CLDT(1,1,LAT),SFCPR(1,LAT),DTACC,NMTCLD,LAN) CALL ZNLACM( 384 ,CLCV(1,1,LAT),SFCPR(1,LAT),DTACC,NMTCCV,LAN) CALL ACCDIA( 384 ,CLDT(1,1,LAT),DTACC,KDTCLD,GDA(1,1,LAT)) CALL ACCDIA( 384 ,CLCV(1,1,LAT),DTACC,KDTCCV,GDA(1,1,LAT)) 1039 CONTINUE DO 1041 LAT=LATIN1,LATIN2 LAN=LAT-LATIN1+1 CALL PUTDIA(LAT,NWGDA*KDGDA,GDA(1,1,LAN)) 1041 CONTINUE ENDIF CKZ PROTECTION AGAINST PREMATURE INTERPOLATION ENDS WITH ABOVE ENDIF CKZ IF(ITIMSW.EQ.1) THEN IF(LATDON.GT.1 .AND. ITIMSW.EQ.1) THEN CALL GGINTF(SWHR, 384 ,NCPUS1, 47 , 1 SWH(1,1,LATIN1), 384 ,LATOUT, 47 , 28 , 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, 3 LTWIDL,LATRD1,LATIN1) CALL GGINTF(SFNSWR, 384 ,NCPUS1, 47 , 1 SFCNSW(1,LATIN1), 384 ,LATOUT, 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, 3 LTWIDL,LATRD1,LATIN1) CSIB... C....... INTERPOLATE 4 COMPONENTS OF DOWNWARD SW FLUX TO FCST GRID C-SIB CALL GGINTF(GDFVDR, 384 ,NCPUS1, 47 , C-SIB1 GDFVDF(1,LATIN1), 384 ,LATOUT, 47 ,1, C-SIB2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, C-SIB3 LTWIDL,LATRD1,LATIN1) C-SIB CALL GGINTF(GDFNDR, 384 ,NCPUS1, 47 , C-SIB1 GDFNDF(1,LATIN1), 384 ,LATOUT, 47 ,1, C-SIB2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, C-SIB3 LTWIDL,LATRD1,LATIN1) C-SIB CALL GGINTF(GDFVBR, 384 ,NCPUS1, 47 , C-SIB1 GDFVBF(1,LATIN1), 384 ,LATOUT, 47 ,1, C-SIB2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, C-SIB3 LTWIDL,LATRD1,LATIN1) C-SIB CALL GGINTF(GDFNBR, 384 ,NCPUS1, 47 , C-SIB1 GDFNBF(1,LATIN1), 384 ,LATOUT, 47 ,1, C-SIB2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, C-SIB3 LTWIDL,LATRD1,LATIN1) CSIB... ENDIF CKZ IF(ITIMLW.EQ.1) THEN IF(LATDON.GT.1 .AND. ITIMLW.EQ.1) THEN CALL GGINTF(HLWR, 384 ,NCPUS1, 47 , 1 HLW(1,1,LATIN1), 384 ,LATOUT, 47 , 28 , 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, 3 LTWIDL,LATRD1,LATIN1) CALL GGINTF(SFDLWR, 384 ,NCPUS1, 47 , 1 SFCDLW(1,LATIN1), 384 ,LATOUT, 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, 3 LTWIDL,LATRD1,LATIN1) CALL GGINTF(TSFLWR, 384 ,NCPUS1, 47 , 1 TSFLW(1,LATIN1), 384 ,LATOUT, 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKR, 3 LTWIDL,LATRD1,LATIN1) ENDIF CKZ LATDON=LATDON+(LAT2-LAT1+1) CALL SYNDIA 10000 CONTINUE CC DO 600 LAT=1, 94 DO 600 K=1, 28 ZONHT(K,LAT) = ZONHT(K,LAT) * 86400. E 0 600 CONTINUE IF( 94 .GE.18) THEN C... PRINT MEAN HEATING RATES IF(ITIMLW.EQ.1.AND.ITIMSW.EQ.1) THEN CALL PROFZL(ZONHT,CLDSIG,COLRAR,FHOUR, 28 ,1) ENDIF C... PRINT MEAN CONVECTIVE CLD AMT,TOP,BOT CALL PROFZL(AVECV,CLDSIG,COLRAR,FHOUR,3,5) C... PRINT MEAN CLOUD DIAGNOSTICS CALL PROFZL(AVECLD,CLDSIG,COLRAR,FHOUR, 28 ,2) CALL PROFZL(CLDL,CLDSIG,COLRAR,FHOUR,4,3) ENDIF C C.... INTERPOLATE DIAGNOSTIC FLUXES (BI-LINEAR) DO 650 K=1, 47 DO 650 J=1, 384 CVAVG(J,K) = CVAVG(J,K) + RADDT * CV(J,K) 650 CONTINUE IF(INISTP.NE.0) THEN RUNRAD=.FALSE. ELSE RUNRAD=.TRUE. ENDIF 20000 CONTINUE C.... RETURN END SUBROUTINE GLOOPZ(NZNL,NSFC) C................................................................. C................BEGIN TWOLOOP(COMFIBM)........................ C.... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.................SOF TWOLOOP(COMFIBM)........................ C................................................................ REAL DSWSFC( 384 , 47 ),USWSFC( 384 , 47 ) REAL WORKGG( 384 ) REAL DUMTN( 384 , 47 ) C................................................................. SECPHY=SHOUR SECSWR=MAX(SHOUR,3600.*DTSWAV) SECLWR=MAX(SHOUR,3600.*DTLWAV) CALL GGINTF(FLUXR(1,1,4), 384 , 47 , 47 , 1 DSWSFC, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKGG,1,1,1) CALL GGINTF(FLUXR(1,1,3), 384 , 47 , 47 , 1 USWSFC, 384 , 47 , 47 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORKGG,1,1,1) C IF(NZNL.GT.0) THEN CALL MTNTRQ(SHOUR,SNNP1,COLRAB,GZ,Z00,PSMEAN,DUMTN) CALL ZNLAVZ( 47 , 384 ,SECPHY,SECSWR, & DUMTN,SLMSK,SHELEG,DSWSFC,USWSFC) CALL ZNLDIA(NZNL,THOUR,IDATE,KDT, 47 , 28 ,WGB,COLRAB,DEL) ENDIF C IF(NSFC.GT.0) &CALL WRTSFC(FHOUR,THOUR,IDATE,NSFC,SLMSK,COLRAB, & DUSFC,DVSFC,DTSFC,DQSFC,TSEA,SMC,STC, & SHELEG,SECSWR,SECLWR, & DLWSFC,ULWSFC,GESHEM,BENGSH,GFLUX, & FLUXR,ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, & U10M,V10M,T2M,Q2M,PSURF,ZORL,TMPMAX,TMPMIN, & SNOWFALL,SNOWEVAP,SNOWMELT, & RUNOFF,EP,CLDWRK,DUGWD,DVGWD,HPBL,PWAT) C RETURN END SUBROUTINE MTNTRQ(DT,SNNP1,COLRAB,ZS,Z00,PSMEAN,DUMTN) REAL SNNP1( 4032 ),COLRAB( 47 ) REAL ZS( 4032 ),PSMEAN( 384 , 47 ),DUMTN( 384 , 47 ) REAL SPC( 4033 ,3),SPCTOP(2, 63 ),QTT( 4032 ),QVV( 4158 ) REAL SYN( 386 ,2) ASQ= 6.3712E+6 * 6.3712E+6 / 9.8000E+0 DO J=3, 4032 SPC(J,1)=ZS(J)*ASQ/SNNP1(J) ENDDO SPC(1,1)=Z00 SPC(2,1)=0. CALL DELLNP(SPC(1,1),SPC(1,3),SPCTOP,SPC(1,2)) C$DOACROSS SHARE(COLRAB,SPC,DT,PSMEAN,DUMTN), C$& LOCAL(LAT,QTT,QVV,SYN,DUMMY,I,PSREF) CMIC$ DO ALL CMIC$& PRIVATE(LAT,QTT,QVV,SYN,DUMMY,I,PSREF) CMIC$& SHARED(COLRAB,SPC,DT,PSMEAN,DUMTN) DO LAT=1, 47 CALL PLN2I(QTT,QVV,COLRAB,LAT) CALL SUMS2I(SPC,SYN,QTT,2) CALL FTI_LONB(SYN,DUMMY,2*2,1) DO I=1, 384 PSREF=DT*101.325*(1.-SYN(I,1)/8.E3) DUMTN(I,LAT)=1.E3* 6.3712E+6 *(PSMEAN(I,LAT)-PSREF)*SYN(I,2) ENDDO ENDDO RETURN END CFPP$ NOCONCUR R SUBROUTINE GOZRIM(QLNT,QLNV,QDERT,EPSI,LAT,RCS2,WGTL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GOZRMT COMPUTES DERIVATIVES OF LEGENDRES. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-11-02 C C ABSTRACT: COMPUTES DERIVATIVES OF ASSOCIATED LEGENDRE FUNCTIONS C AND FOR CONVENIENCE, OTHER REQUIRED PRODUCTS OF C LEGENDRES AND FACTORS INVOLVING WAVE NUMBER AND LATITUDE. C THE RESULTING ARRAYS ARE REQUIRED FOR THE APPLICATION C OF DIVERGENCE AND CURL OPERATORS IN MSU22 AND PSU22. C C PROGRAM HISTORY LOG: C 88-11-02 JOSEPH SELA C C USAGE: CALL GOZRMT (QLNT,QLNV,QDERT,EPS,LAT,QLNWCT,RCS2,WGTL) C INPUT ARGUMENT LIST: C QLNT - DOUBLED SCALAR TRIANGULAR C ARRAY OF ASSOCIATED LEGENDRE FUNCTIONS AT C A GIVEN LATITUDE. C ON INPUT, VALUES OF QLNT ARE A SUBSET OF QLNV. C QLNV - DOUBLED VECTOR TRIANGULAR C ARRAY OF ASSOCIATED LEGENDRE FUNCTIONS AT C A GIVEN LATITUDE. C EPS - ARRAY OF FUNCTION OF WAVE NUMBER COMPUTED IN EPSLON. C EPS IS USED ONLY DURING FIRST CALL TO GOZRMT. C LAT - LATITUDE INDEX. C RCS2 - ARRAY OF CONSTANTS COMPUTED IN GLATS (1/SIN(LAT)**2). C WGTL - WEIGHT AT GAUSSIAN LATITUDE. C MULTIPLIER OF OUTPUT ARRAYS QLNT, QDERT, QLNWCT. C C OUTPUT ARGUMENT LIST: C QLNT - DOUBLED SCALAR TRIANGULAR C ARRAY OF QLNT*N*(N+1)*1/A**2 TIMES WGTL. C QDERT - DOUBLED SCALAR TRIANGULAR C ARRAY OF LEGENDRE DERIVATIVES TIMES WGTL. C QLNWCT - DOUBLED SCALAR TRIANGULAR C ARRAY OF QLNT*L*RCS2(LAT)/A TIMES WGTL. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ CRAY SAVE CC DIMENSION QLNT( 4032 ) DIMENSION QLNV( 4158 ) DIMENSION QDERT( 4032 ) DIMENSION EPSI( 64 , 63 ) DIMENSION RCS2( 47 ) CC COMMON /GOZCOM/ DXA( 4032 ),DXB( 4032 ) CC CCC PART BETWEEN GUARDS MADE INTO SR GGOZRI. CCC 7 DEC 1990 M. ROZWODOSKI CC CC COMPUTE PLN DERIVATIVES IN IBM ORDER. WCSA=RCS2(LAT)*WGTL/ 6.3712E+6 CC LP0 = 0 LP1 = 2 LEN = 126 DO 640 I=1, 63 DO 620 LL=1,LEN QDERT(LL+LP0) = QLNV(LL+LP1) * DXB(LL+LP0) 620 CONTINUE LP1 = LP1 + LEN + 2 LP0 = LP0 + LEN LEN = LEN - 2 640 CONTINUE CC LEND = 4032 - 4 DO 720 LL=1,LEND QDERT(LL+2) = QDERT(LL+2) + QLNT(LL) * DXA(LL+2) 720 CONTINUE CC DO 760 LL=1, 4032 QDERT(LL) = QDERT(LL) * WCSA 760 CONTINUE CC CC CC RETURN END SUBROUTINE GGOZRM(EPSI) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GGOZRM SETS COMMON FOR SUBROUTINE GOZRMT. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 91-03-14 C C ABSTRACT: INITIALIZES THE CONSTANT VARIABLES AND ARRAYS C OF A COMMON FOR SUBROUTINE GOZRMT. C C PROGRAM HISTORY LOG: C 91-03-14 JOSEPH SELA C C USAGE: CALL GGOZRM ( EPS ) C C REMARKS: CALL SUBROUTINE ONCE BEFORE CALLS TO GOZRMT. C REFER TO GOZRMT FOR ADDITIONAL DOCUMENTATION. C C ATTRIBUTES: C LANGUAGE: FORTRAN, CFT77. C MACHINE: CRAY Y-MP. C C$$$ CC DIMENSION EPSI( 64 , 63 ) CC DIMENSION DXINT( 4032 ) DIMENSION DX( 126 , 64 ) DIMENSION DEPS( 126 , 64 ) CC COMMON /GOZCOM/ DXA( 4032 ),DXB( 4032 ) CC DO 200 LL=1, 126 DXINT(2*LL-1) = LL DXINT(2*LL ) = LL 200 CONTINUE LP = 0 DO 240 I=1, 64 DO 220 LL=1, 126 DX(LL,I) = DXINT(LL+LP) 220 CONTINUE LP = LP + 2 240 CONTINUE DO 280 I=1, 64 DO 260 LL=1, 63 DEPS(2*LL-1,I) = EPSI(I,LL) DEPS(2*LL ,I) = EPSI(I,LL) 260 CONTINUE 280 CONTINUE DO 300 LL=1, 126 DXA(LL) = 0.0 300 CONTINUE LP1 = 126 LEN = 126 - 2 DO 340 I=1, 62 DO 320 LL=1,LEN DXA(LL+LP1) = DX(LL,I+1) * DEPS(LL,I+1) DXB(LL+LP1) = -DX(LL,I ) * DEPS(LL,I+2) 320 CONTINUE LP1 = LP1 + LEN LEN = LEN - 2 340 CONTINUE DO 380 I=1, 64 DO 360 LL=1, 126 DX(LL,I) = DX(LL,I) - 1. E 0 360 CONTINUE 380 CONTINUE DO 400 LL=1, 126 DXB(LL) = -DX(LL,1) * DEPS(LL,2) 400 CONTINUE CC CC TRANSPOSE SCALAR ARRAYS DXA, DXB, DXC, DXD CC FROM CRAY ORDER TO IBM ORDER. CALL TRANSO (DXA, 2) CC RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R SUBROUTINE GRIBIT(F,LBM,IDRT,IM,JM,MXBIT,COLAT1, & ILPDS,IPTV,ICEN,IGEN,IBMS,IPU,ITL,IL1,IL2, & IYR,IMO,IDY,IHR,IFTU,IP1,IP2,ITR, & INA,INM,ICEN2,IDS,IENS, & XLAT1,XLON1,XLAT2,XLON2,DELX,DELY,ORITRU,PROJ, & GRIB,LGRIB,IERR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GRIBIT CREATE GRIB MESSAGE C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 C C ABSTRACT: CREATE A GRIB MESSAGE FROM A FULL FIELD. C AT PRESENT, ONLY GLOBAL LATLON GRIDS AND GAUSSIAN GRIDS C AND REGIONAL POLAR PROJECTIONS ARE ALLOWED. C C PROGRAM HISTORY LOG: C 92-10-31 IREDELL C 94-05-04 JUANG (FOR GSM AND RSM USE) C C USAGE: CALL GRIBIT(F,LBM,IDRT,IM,JM,MXBIT,COLAT1, C & ILPDS,IPTV,ICEN,IGEN,IBMS,IPU,ITL,IL1,IL2, C & IYR,IMO,IDY,IHR,IFTU,IP1,IP2,ITR, C & INA,INM,ICEN2,IDS,IENS, C & XLAT1,XLON1,DELX,DELY,ORITRU,PROJ, C & GRIB,LGRIB,IERR) C INPUT ARGUMENT LIST: C F - REAL (IM*JM) FIELD DATA TO PACK INTO GRIB MESSAGE C LBM - LOGICAL (IM*JM) BITMAP TO USE IF IBMS=1 C IDRT - INTEGER DATA REPRESENTATION TYPE C (0 FOR LATLON OR 4 FOR GAUSSIAN OR 5 FOR POLAR) C IM - INTEGER LONGITUDINAL DIMENSION C JM - INTEGER LATITUDINAL DIMENSION C MXBIT - INTEGER MAXIMUM NUMBER OF BITS TO USE (0 FOR NO LIMIT) C COLAT1 - REAL FIRST COLATITUDE OF GRID IF IDRT=4 (RADIANS) C ILPDS - INTEGER LENGTH OF THE PDS (USUALLY 28) C IPTV - INTEGER PARAMETER TABLE VERSION (USUALLY 1) C ICEN - INTEGER FORECAST CENTER (USUALLY 7) C IGEN - INTEGER MODEL GENERATING CODE C IBMS - INTEGER BITMAP FLAG (0 FOR NO BITMAP) C IPU - INTEGER PARAMETER AND UNIT INDICATOR C ITL - INTEGER TYPE OF LEVEL INDICATOR C IL1 - INTEGER FIRST LEVEL VALUE (0 FOR SINGLE LEVEL) C IL2 - INTEGER SECOND LEVEL VALUE C IYR - INTEGER YEAR C IMO - INTEGER MONTH C IDY - INTEGER DAY C IHR - INTEGER HOUR C IFTU - INTEGER FORECAST TIME UNIT (1 FOR HOUR) C IP1 - INTEGER FIRST TIME PERIOD C IP2 - INTEGER SECOND TIME PERIOD (0 FOR SINGLE PERIOD) C ITR - INTEGER TIME RANGE INDICATOR (10 FOR SINGLE PERIOD) C INA - INTEGER NUMBER INCLUDED IN AVERAGE C INM - INTEGER NUMBER MISSING FROM AVERAGE C ICEN2 - INTEGER FORECAST SUBCENTER C (USUALLY 0 BUT 1 FOR REANAL OR 2 FOR ENSEMBLE) C IDS - INTEGER DECIMAL SCALING C IENS - INTEGER (5) ENSEMBLE EXTENDED PDS VALUES C (APPLICATION,TYPE,IDENTIFICATION,PRODUCT,SMOOTHING) C (USED ONLY IF ICEN2=2 AND ILPDS>=45) C XLAT1 - REAL FIRST POINT OF REGIONAL LATITUDE (RADIANS) C XLON1 - REAL FIRST POINT OF REGIONAL LONGITUDE (RADIANS) C XLAT2 - REAL LAST POINT OF REGIONAL LATITUDE (RADIANS) C XLON2 - REAL LAST POINT OF REGIONAL LONGITUDE (RADIANS) C DELX - REAL DX ON 60N FOR REGIONAL (M) C DELY - REAL DY ON 60N FOR REGIONAL (M) C PROJ - REAL POLAR PROJECTION FLAG 1 FOR NORTH -1 FOR SOUTH C MERCATER PROJECTION 0 C ORITRU - REAL ORIENTATION OF REGIONAL POLAR PROJECTION OR C TRUTH FOR REGIONAL MERCATER PROJECTION C C OUTPUT ARGUMENT LIST: C GRIB - CHARACTER (LGRIB) GRIB MESSAGE C LGRIB - INTEGER LENGTH OF GRIB MESSAGE C (NO MORE THAN 100+ILPDS+IM*JM*(MXBIT+1)/8) C IERR - INTEGER ERROR CODE (0 FOR SUCCESS) C C SUBPROGRAMS CALLED: C GTBITS - COMPUTE NUMBER OF BITS AND ROUND DATA APPROPRIATELY C W3FI72 - ENGRIB DATA INTO A GRIB1 MESSAGE C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C C$$$ REAL F(IM*JM) LOGICAL LBM(IM*JM) CHARACTER GRIB(*) PARAMETER(NIBM= 192 * 94 ) INTEGER IBM(NIBM),IPDS(100),IGDS(100),IBDS(100) C-CRA INTEGER IBM(IM*JM*IBMS+1-IBMS),IPDS(100),IGDS(100),IBDS(100) REAL FR(NIBM) C-CRA REAL FR(IM*JM) C-CRA CHARACTER PDS(ILPDS) CHARACTER PDS(100) C INTEGER IENS(5),KPROB(2),KCLUST(16),KMEMBR(80) DIMENSION XPROB(2) C INTEGER*4 IENS4(5),KPROB4(2),KCLUST4(16),KMEMBR4(80) INTEGER*4 IBM4(NIBM) INTEGER*4 IPDS4(100),IGDS4(100),IBDS4(100) INTEGER*4 NBIT4,NF4,NFO4,LGRIB4,IERR4 C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DETERMINE GRID PARAMETERS PI=ACOS(-1.) NF=IM*JM IF(IDRT.EQ.0) THEN IF(IM.EQ.144.AND.JM.EQ.73) THEN IGRID=2 ELSEIF(IM.EQ.360.AND.JM.EQ.181) THEN IGRID=3 ELSE IGRID=255 ENDIF IRESFL=128 ISCAN=0 LAT1=NINT(90.E3) LON1=0 LATI=NINT(180.E3/(JM-1)) LONI=NINT(360.E3/IM) IGDS09=-LAT1 IGDS10=-LONI IGDS11=LATI IGDS12=LONI ELSEIF(IDRT.EQ.4) THEN IF(IM.EQ.192.AND.JM.EQ.94) THEN IGRID=98 ELSEIF(IM.EQ.384.AND.JM.EQ.190) THEN IGRID=126 ELSE IGRID=255 ENDIF IRESFL=128 ISCAN=0 LAT1=NINT(90.E3-180.E3/PI*COLAT1) LON1=0 LATI=JM/2 LONI=NINT(360.E3/IM) IGDS09=-LAT1 IGDS10=-LONI IGDS11=LATI IGDS12=LONI IGDS13=ISCAN ELSEIF(IDRT.EQ.5) THEN ! POLAR PROJECTION IGRID=255 LAT1=NINT(180.E3/ACOS(-1.) * XLAT1) LON1=NINT(180.E3/ACOS(-1.) * XLON1) IRESFL=0 IGDS09=NINT(ORITRU*1.E3) IGDS10=DELX IGDS11=DELY IF( NINT(PROJ).EQ.1 ) IGDS12=0 ! NORTH POLAR PROJ IF( NINT(PROJ).EQ.-1 ) IGDS12=128 ! SOUTH POLAT PROJ ISCAN=64 IGDS13=ISCAN ELSEIF(IDRT.EQ.1) THEN ! MERCATER PROJECTION IGRID=255 LAT1=NINT(180.E3/ACOS(-1.) * XLAT1) LON1=NINT(180.E3/ACOS(-1.) * XLON1) IRESFL=0 IGDS09=NINT(180.E3/ACOS(-1.) * XLAT2) IGDS10=NINT(180.E3/ACOS(-1.) * XLON2) IGDS11=DELX IGDS12=DELY IGDS13=NINT(ORITRU*1.E3) ISCAN=64 IGDS14=ISCAN ELSE IERR=40 RETURN ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C RESET TIME RANGE PARAMETER IN CASE OF OVERFLOW IF(ITR.GE.2.AND.ITR.LE.5.AND.IP2.GE.256) THEN JP1=IP2 JP2=0 JTR=10 ELSE JP1=IP1 JP2=IP2 JTR=ITR ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C FILL PDS PARAMETERS IPDS(01)=ILPDS ! LENGTH OF PDS IPDS(02)=IPTV ! PARAMETER TABLE VERSION ID IPDS(03)=ICEN ! CENTER ID IPDS(04)=IGEN ! GENERATING MODEL ID IPDS(05)=IGRID ! GRID ID IPDS(06)=1 ! GDS FLAG IPDS(07)=IBMS ! BMS FLAG IPDS(08)=IPU ! PARAMETER UNIT ID IPDS(09)=ITL ! TYPE OF LEVEL ID IPDS(10)=IL1 ! LEVEL 1 OR 0 IPDS(11)=IL2 ! LEVEL 2 c IPDS(12)=IYR ! YEAR IPDS(12)=mod((IYR-1),100) + 1 IPDS(13)=IMO ! MONTH IPDS(14)=IDY ! DAY IPDS(15)=IHR ! HOUR IPDS(16)=0 ! MINUTE IPDS(17)=IFTU ! FORECAST TIME UNIT ID IPDS(18)=JP1 ! TIME PERIOD 1 IPDS(19)=JP2 ! TIME PERIOD 2 OR 0 IPDS(20)=JTR ! TIME RANGE INDICATOR IPDS(21)=INA ! NUMBER IN AVERAGE IPDS(22)=INM ! NUMBER MISSING c IPDS(23)=20 ! CENTURY IPDS(23)=((IYR-IPDS(12))/100) + 1 if (IYR/100 .eq. 0) then if (IYR.eq.0) then c 2000 IPDS(12) = 100 IPDS(23) = 20 else if (IYR.lt.45) then c 2001-2044 IPDS(12) = IYR IPDS(23) = 21 else c 1945-1999 IPDS(12) = IYR IPDS(23) = 20 endif endif IPDS(24)=ICEN2 ! FORECAST SUBCENTER IPDS(25)=IDS ! DECIMAL SCALING C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C FILL GDS AND BDS PARAMETERS IGDS(01)=0 ! NUMBER OF VERTICAL COORDS IGDS(02)=255 ! VERTICAL COORD FLAG IGDS(03)=IDRT ! DATA REPRESENTATION TYPE IGDS(04)=IM ! EAST-WEST POINTS IGDS(05)=JM ! NORTH-SOUTH POINTS IGDS(06)=LAT1 ! LATITUDE OF ORIGIN IGDS(07)=LON1 ! LONGITUDE OF ORIGIN IGDS(08)=IRESFL ! RESOLUTION FLAG IGDS(09)=IGDS09 ! LATITUDE OF END OR ORIENTATION IGDS(10)=IGDS10 ! LONGITUDE OF END OR DX IN METER ON 60N IGDS(11)=IGDS11 ! LAT INCREMENT OR GAUSSIAN LATS OR DY IN METER IGDS(12)=IGDS12 ! LONGITUDE INCREMENT OR PROJECTION IGDS(13)=IGDS13 ! SCANNING MODE OR LAT OF INTERCUT ON EARTH FOR IGDS(14)=IGDS14 ! NOT USED OR SCANNING MODE FOR MERCATER IGDS(15)=0 ! NOT USED IGDS(16)=0 ! NOT USED IGDS(17)=0 ! NOT USED IGDS(18)=0 ! NOT USED IBDS(1)=0 ! BDS FLAGS IBDS(2)=0 ! BDS FLAGS IBDS(3)=0 ! BDS FLAGS IBDS(4)=0 ! BDS FLAGS IBDS(5)=0 ! BDS FLAGS IBDS(6)=0 ! BDS FLAGS IBDS(7)=0 ! BDS FLAGS IBDS(8)=0 ! BDS FLAGS IBDS(9)=0 ! BDS FLAGS C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C FILL BITMAP AND COUNT VALID DATA. RESET BITMAP FLAG IF ALL VALID. NBM=NF IF(IBMS.NE.0) THEN NBM=0 DO I=1,NF IF(LBM(I)) THEN IBM(I)=1 NBM=NBM+1 ELSE IBM(I)=0 ENDIF ENDDO IF(NBM.EQ.NF) IPDS(7)=0 ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C ROUND DATA AND DETERMINE NUMBER OF BITS IF(NBM.EQ.0) THEN DO I=1,NF FR(I)=0. ENDDO NBIT=0 ELSE CALL GTBITS(IPDS(7),IDS,NF,IBM,F,FR,FMIN,FMAX,NBIT) C WRITE(0,'("GTBITS:",4I4,4X,2I4,4X,2G16.6)') C & IPU,ITL,IL1,IL2,IDS,NBIT,FMIN,FMAX IF(MXBIT.GT.0) NBIT=MIN(NBIT,MXBIT) ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CREATE PRODUCT DEFINITION SECTION DO I=1,100 IPDS4(I)=IPDS(I) ENDDO CALL W3FI68(IPDS4,PDS) C-CRA CALL W3FI68(IPDS,PDS) IF(ICEN2.EQ.2.AND.ILPDS.GE.45) THEN ILAST=45 DO I=1,5 IENS4(I)=IENS(I) ENDDO DO I=1,2 KPROB4(I)=KPROB(I) ENDDO DO I=1,16 KCLUST4(I)=KCLUST(I) ENDDO DO I=1,80 KMEMBR4(I)=KMEMBR(I) ENDDO ILAST4=ILAST CALL PDSENS(IENS4,KPROB4,XPROB,KCLUST4,KMEMBR4,ILAST4,PDS) C-CRA CALL PDSENS(IENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CREATE GRIB MESSAGE NBIT4=NBIT DO I=1,100 IPDS4(I)=IPDS(I) ENDDO DO I=1,100 IGDS4(I)=IGDS(I) ENDDO DO I=1,NF IBM4(I)=IBM(I) ENDDO NF4=NF DO I=1,100 IBDS4(I)=IBDS(I) ENDDO CALL W3FI72(0,FR,0,NBIT4,1,IPDS4,PDS, & 1,255,IGDS4,0,0,IBM4,NF4,IBDS4, & NFO4,GRIB,LGRIB4,IERR4) NFO=NFO4 LGRIB=LGRIB4 IERR=IERR4 C-CRA CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, C-CRA& 1,255,IGDS,0,0,IBM,NF,IBDS, C-CRA& NFO,GRIB,LGRIB,IERR) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- CFPP$ NOCONCUR R SUBROUTINE GTBITS(IBM,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GTBITS COMPUTE NUMBER OF BITS AND ROUND FIELD. C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 C C ABSTRACT: THE NUMBER OF BITS REQUIRED TO PACK A GIVEN FIELD C AT A PARTICULAR DECIMAL SCALING IS COMPUTED USING THE FIELD RANGE. C THE FIELD IS ROUNDED OFF TO THE DECIMAL SCALING FOR PACKING. C THE MINIMUM AND MAXIMUM ROUNDED FIELD VALUES ARE ALSO RETURNED. C GRIB BITMAP MASKING FOR VALID DATA IS OPTIONALLY USED. C C PROGRAM HISTORY LOG: C 92-10-31 IREDELL C C USAGE: CALL GTBITS(IBM,IDS,LEN,MG,G,GMIN,GMAX,NBIT) C INPUT ARGUMENT LIST: C IBM - INTEGER BITMAP FLAG (=0 FOR NO BITMAP) C IDS - INTEGER DECIMAL SCALING C (E.G. IDS=3 TO ROUND FIELD TO NEAREST MILLI-VALUE) C LEN - INTEGER LENGTH OF THE FIELD AND BITMAP C MG - INTEGER (LEN) BITMAP IF IBM=1 (0 TO SKIP, 1 TO KEEP) C G - REAL (LEN) FIELD C C OUTPUT ARGUMENT LIST: C GROUND - REAL (LEN) FIELD ROUNDED TO DECIMAL SCALING C (SET TO ZERO WHERE BITMAP IS 0 IF IBM=1) C GMIN - REAL MINIMUM VALID ROUNDED FIELD VALUE C GMAX - REAL MAXIMUM VALID ROUNDED FIELD VALUE C NBIT - INTEGER NUMBER OF BITS TO PACK C C SUBPROGRAMS CALLED: C ISRCHNE - FIND FIRST VALUE IN AN ARRAY NOT EQUAL TO TARGET VALUE C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C C$$$ DIMENSION MG(LEN),G(LEN),GROUND(LEN) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON DS=10.**IDS IF(IBM.EQ.0) THEN GROUND(1)=NINT(G(1)*DS)/DS GMAX=GROUND(1) GMIN=GROUND(1) DO I=2,LEN GROUND(I)=NINT(G(I)*DS)/DS GMAX=MAX(GMAX,GROUND(I)) GMIN=MIN(GMIN,GROUND(I)) ENDDO ELSE I1=ISRCHNE(LEN,MG,1,0) IF(I1.GT.0.AND.I1.LE.LEN) THEN DO I=1,I1-1 GROUND(I)=0. ENDDO GROUND(I1)=NINT(G(I1)*DS)/DS GMAX=GROUND(I1) GMIN=GROUND(I1) DO I=I1+1,LEN IF(MG(I).NE.0) THEN GROUND(I)=NINT(G(I)*DS)/DS GMAX=MAX(GMAX,GROUND(I)) GMIN=MIN(GMIN,GROUND(I)) ELSE GROUND(I)=0. ENDIF ENDDO ELSE DO I=1,LEN GROUND(I)=0. ENDDO GMAX=0. GMIN=0. ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C COMPUTE NUMBER OF BITS NBIT=LOG((GMAX-GMIN)*DS+0.9)/LOG(2.)+1. C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END FUNCTION ISRCHNE(N,IX,INCX,ITARGET) INTEGER IX(*),ITARGET J=1 ISRCHNE=0 IF(N.LE.0) RETURN IF(INCX.LT.0) J=1-(N-1)*INCX DO I=1,N IF(IX(J).NE.ITARGET) THEN ISRCHNE=I RETURN ENDIF J=J+INCX ENDDO RETURN END SUBROUTINE GRIDIFF(DELTIM,SL,PSLAP,GT0,GQ0) C DIMENSION SL( 28 ) DIMENSION PSLAP( 386 ) C DIMENSION GT0( 386 , 28 ) DIMENSION GQ0( 386 , 28 ) C DO K=1, 28 KD=MAX(K-1,1) KU=MIN(K+1, 28 ) DO J=1, 384 GT0(J,K)=GT0(J,K)+PSLAP(J)*DELTIM* 1 (GT0(J,KU)-GT0(J,KD))*SL(K)/(SL(KU)-SL(KD)) ENDDO ENDDO C DO K=1, 28 DO J=1, 384 GQ0(J,K)=GQ0(J,K)+PSLAP(J)*DELTIM* 1 (GQ0(J,KU)-GQ0(J,KD))*SL(K)/(SL(KU)-SL(KD)) ENDDO ENDDO C RETURN END SUBROUTINE GRLWSW(SIGL,NFILE) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) PARAMETER (LNGTH=37*L) PARAMETER (NL=81,NLP1=NL+1,NLGTH=37*NL) COMMON /RDFSAV/ DEGRAD,HSIGMA,DAYSEC,RCO2 C ************************************************************** C SEASONAL CLIMATOLOGIES OF O3 (OBTAINED ON USER VERTICAL COORD) C DEFINED AS 5 DEG LAT MEANS N.P.->S.P. C ************************************************************** COMMON /SAVMEM/ C --- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... 1 DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L) DIMENSION RAD1(LNGTH), RAD2(LNGTH), RAD3(LNGTH), RAD4(LNGTH) EQUIVALENCE (RAD1(1),DDUO3N(1,1)),(RAD2(1),DDO3N2(1,1)) EQUIVALENCE (RAD3(1),DDO3N3(1,1)),(RAD4(1),DDO3N4(1,1)) C --- SEASONAL CLIMATOLOGIES OF O3 ON THE DETAILED GFDL COORDINATE... C INTERPOLATION TO EACH POINT PRESSURE PROFILE DONE IN OZON2D C (SEE GLOOPR) COMMON /SEASO3/ C --- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... 1 XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL) 2, PRGFDL(NL) DIMENSION XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) EQUIVALENCE (XRAD1(1),XDUO3N(1,1)),(XRAD2(1),XDO3N2(1,1)) EQUIVALENCE (XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1)) C DIMENSION SIGL(L),PSTD(NLP1) C ******************************************************** C * ONE TIME COMPUTATION OF NECESSARY QUANTITIES * C ******************************************************** C===> ... INITIALIZE ARRAYS,GET CONSTANTS,ETC... DEGRAD=180.0 E 0/ 3.141593E+0 HSIGMA=5.673 E -5 DAYSEC=1.1574 E -5 C===> ... ATMOSPERIC CARBON DIOXIDE CONCENTRATION IS NOW READ BY CONRAD C BUT IT DEFAULTS TO 330 PPM FOR BACKWARD COMPATIBILITY. RCO2=3.3 E -4 CALL HCONST C===> ... INTERPOLATE CLIMO O3 TO THE CURRENT VERTICAL COORDINATE C NEED LAYER SIGMA, GET FROM PSFC AND LAYER P FOR I=1 CALL O3INT(DDUO3N,SIGL) C===> ... COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES C WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3 C AND PSFC=1013.25 MB ......K.A.C. DEC94 CALL O3INTN(XDUO3N,PSTD) CALL CONRAD(NFILE,RCO2) C===> ... AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, C SO THAT TIME AND SPACE INTERPOLATION WILL WORK DO 5 I=1,LNGTH AVG=.25 E 0*(RAD1(I)+RAD2(I)+RAD3(I)+RAD4(I)) A1=.5 E 0*(RAD2(I)-RAD4(I)) B1=.5 E 0*(RAD1(I)-RAD3(I)) B2=.25 E 0*((RAD1(I)+RAD3(I))-(RAD2(I)+RAD4(I))) RAD1(I)=AVG RAD2(I)=A1 RAD3(I)=B1 RAD4(I)=B2 5 CONTINUE C===> ... AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, C SO THAT TIME AND SPACE INTERPOLATION WILL WORK C (SEE SUBPROGRAM OZON2D) DO 10 I=1,NLGTH AVG=.25 E 0*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I)) A1=.5 E 0*(XRAD2(I)-XRAD4(I)) B1=.5 E 0*(XRAD1(I)-XRAD3(I)) B2=.25 E 0*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I))) XRAD1(I)=AVG XRAD2(I)=A1 XRAD3(I)=B1 XRAD4(I)=B2 10 CONTINUE C===> ... GET GFDL PRESSURE IN CB (FLIP VERTICAL COORDINATE) DO 20 N=1,NL PRGFDL(N) = PSTD(NL+1-N)*1. E -4 20 CONTINUE C RETURN END SUBROUTINE GRRAD1(DGRS,PLAMGR,PPHIGR,UGRS,VGRS,TGRS,QGRS,PGR, CYH951 ALBEDR,SLMSKR,COSZER,RLON,RLAT, 1 ALBEDR,SLMSKR,RLON,RLAT, 2 TSEAR,SHELGR,TGR,CVR,CVTR,CVBR,RHCL, CYH953 PPPRSA,OZONEA,ALBDOA,COSZRO,TAUDAR, CYH954 CLDARY,CLDSA,MTOPA,MBOTA, 3 OZONEA,ALBDOA,CLDARY,CLDSA,MTOPA,MBOTA, 5 RRS2,LAT,LATCO,IDTLN,IDTLS,DLON,ISTRAT, CYH956 KDAPRX,SLAG,RSIN1,RCOS1,RCOS2, 6 KALB,JO3,SLAG,RSIN1,RCOS1,RCOS2, 7 FJD,DLT,JSNO,WORKR,LWORKR, 8 CLDTOT,CLDCNV, 9 SFCP, A AVECV,AVECLD,CLDL) CFPP$ NOCONCUR R C.. ************************************************************ C.. * ADDED ACCUMULATION OF CLDS AND CONVECTIVE CLOUD IN DG3 * C.. * K.A.C SEPT 1994 * C.. * CHANGED H,M,L CALCULATION IN CLDJMS (REMOVED FACV) * C.. * AND ADDED PROPER TOTAL CLOUD CALCULATION * C.. * CHANGED AVECLD CALC IN CLDIAG (USED CLDARY) AND * C.. * USED TOTAL CLOUD CALCULATED IN CLDJMS * C.. * K.A.C. NOV94 * C.. * INTERPOLATE O3 PROFILE TO EACH GRIDPOINT, IE USE * C.. * PROPER SURFACE PRESSURE * C.. * K.A.C. DEC94 * C.. * FIX PL1 FOR OPERATIONS, WHERE DGZ IS ON AND DG3 IS OFF, * C.. * ....NOTE DG IS ON IF EITHER DGZ OR DG3 IS ON * C.. * K.A.C. JAN94 * C.. ************************************************************ C C UPDATES MADE TO ADD OCEANIC STRATUS AND TO FIX CONV CLOUD.. C TO GLOOPR - IVV(2),IBL ARE SET=1.... C TO GLOOPR - SET MIN Q TO 1.E-10,RATHER THAN 1.E-6 C TO ANTICIPATE AVOIDING CLD CREATION C IN EXTREMELY DRY,COLD (WINTER) REGIONS C WHERE 1.E-6 COULD IMPLY HI VALU OF RH C TO CLDJMS - MULTITUDE OF CHANGES C UPDATES MADE TO ADD GRID POINT DIAGNOSTICS ..K.A.C...SEP 91 C TO GLOOPR - C UPDATES MADE TO FIX SW APPROX ..K.A.C...NOV 91 C TO COSZMN C UPDATES MADE TO PASS AND RECEIVE SIB DATA ..K.A.C...MAR 92 C TO GLOOPR - C UPDATES MADE TO FIX SW RAD DIAGNOSTICS ..K.A.C...JUN 92 C PROPER DIURNAL WEIGHTING C TO GLOOPR AND COSZMN C UPDATES MADE TO CALCULATE CLEAR-SKY "ON-THE-FLY" KAC AUG 92 C TO GLOOPR,RADFS,FST,SPA,LWR,SWR C ...FOR CLOUD FORCING.... CYH93... C UPDATES MADE FOR THE COMPLETELY NEW CLOUD ROUTINE (CLDJMS),USE C FLAG IVVA TO CONTROL VERTICAL VELOCITY ADJ. C FOR LOW CLD (=0: WITHOUT, =1: WITH) CYH94 NOT USE FLAG IEMIS TO CONTROL CLD EMISS. SCHEME CYH94 NOT (=0: ORIG. SCHEME, =1: TEMP. DEP. SCHEME.) C USE FLAG INVR TO CONTROL LAPSE RATE INVERSION C TYPE OF CLD (=0: WITHOUT, =1: WITH) C TO GLOOPR AND RADFS ...Y.H. ...DEC92 C UPDATES MADE TO CALL CLD OPTICAL PROPERTY ROUTINE (CLDPRP), C TO GIVE CLD EMISSIVITY, OPTICAL DEPTH, LAYER C REFLECTANCE AND TRANSMITANCE C TO GLOOPR AND RADFS ...Y.H. ...FEB93 CYH94 CLDPRP CALLED FROM RADFS... Y.H. ...FEB94 CTUNE C UPDATES MADE TO ALLOW TUNED CLD-RH DATA TO BE USED..CTUNE C TO GLOOPR AND CLDJMS ..K.A.C...DEC 92 C SPATIAL INTERPOLATION OF TABLES ........MAY93 C USE ONLY 1 SET OF TUNING TABLES FOR ALL FCST HRS, C THE TUNING OF THE 24HR FCST .....JAN94 C OLD CODE USED 6 TABLES..SEE CKC94 .....FEB94 C SINCE TUNING DONE FOR H,M,L CLD, VERTICALLY C BLEND THE RELATIONS AT OLD HML BDRIES..JAN94 C UPDATES MADE TO CHANGE DEFINITION OF H,M,L DOMAINS.. C TO GLOOPR,GCLJMS,CLDJMS, CLDPRP K.A.C...DEC92 + AUG93 CYH94 TO GLOOPR, CLDJMS, CLDPRP K.A.C...JAN94 CYH94 TO CLDJMS.. CVTOP = KCVT (NOT KCVT+1) CYH94 AND TO ISTRAT=1 PART...NEW STRATUS + CYH94 ..NO CLOUD BELOW LLYRL.. K.A.C...MAR94 CYH94 ..CHANGES TO CLDPRP.........Y.H...MAR94 CTUNE CYH93... CHL95 MODIFIED TO ALLOW MORE FREQUENT COMPUTATION OF SHORTWAVE FLUX CHL95 ASSUME THAT DTSWAV <= DTLWAV!!!!!.....H.-L. PAN JUL95 CYH95 MODIFIED TO USE M.D.CHOU'S SW RADIATION SCHEME, WITH C WMO AEROSOLS DISTRIBUTIONS, AND B.P.BREIGLEB'S SURFACE C ALBEDO SCHEME. ..............Y.H...SEP95 C KALB IS THE CONTROL FLAG FOR SURFACE ALBEDO C KALB=0 USE THE OLD MATTHEWS DATA, =1 USE THE NEW SCHEME. C JO3 IS THE CONTROL FLAG FOR OZONE CLIMATOLOGY C JO3=0 USE THE OLD GFDL DATA, =1 USE THE NEW NASA DATA CYH95 ... ENDYH C--- C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) CTUNE CKC94 PARAMETER (MCLD=3,NSEAL=2,NBIN=100,NLON=2,NLAT=4,IDA=6) PARAMETER (MCLD=3,NSEAL=2,NBIN=100,NLON=2,NLAT=4) CTUNE C... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... DIMENSION DGRS( 386 , 28 ) DIMENSION PLAMGR( 386 ),PPHIGR( 386 ) DIMENSION UGRS( 386 , 28 ),VGRS( 386 , 28 ) DIMENSION TGRS( 386 , 28 ),QGRS( 386 , 28 ) DIMENSION PGR( 386 ) C.... DIMENSION WORKR( 384 ,LWORKR) C.... CYH95 DIMENSION COSZER( 384 ) C.... DIMENSION RRS2( 47 ) DIMENSION RLON( 384 ),RLAT( 384 ) DIMENSION ALBEDR( 384 ),SLMSKR( 384 ) CYH93 DIMENSION VVEL( 384 , 28 ),SSNOW( 384 ),EMIS( 384 ) DIMENSION VVEL( 384 , 28 ),SSNOW( 384 ) C.... CLDARY CONTAINS MULTI LAYERS OF CLOUD CYH94 DIMENSION CLDARY( 384 , 28 ),CLSTR( 384 ) DIMENSION CLDARY( 384 , 28 ) DIMENSION CLDTOT( 384 , 28 ),CLDCNV( 384 , 28 ) DIMENSION SFCP( 384 ) DIMENSION ICNV( 384 ) CYH94 DIMENSION EMIS0( 384 ,3),TAUC0( 384 ,3) CYH93... C.... CYH95 DIMENSION PPPRSA( 384 , 28 ), DIMENSION 1 OZONEA( 384 , 28 ),ALBDOA( 384 ), CTOT 2 CLDSA( 384 ,3),MTOPA( 384 ,3),MBOTA( 384 ,3), 2 CLDSA( 384 ,4),MTOPA( 384 ,3),MBOTA( 384 ,3), CYH953 COSZRO( 384 ),TAUDAR( 384 ),WRKEMA( 384 ), CYH954 TSEAR( 384 ),SHELGR( 384 ), 3 WRKEMA( 384 ),TSEAR( 384 ),SHELGR( 384 ), 5 CVR( 384 ),CVTR( 384 ),CVBR( 384 ), C ADDED BY BOB GRUMBINE FOR SEA ICE ALBEDO ALGORITHM 6 TGR( 384 ) DIMENSION AVECV(3, 94 ),AVECLD( 28 , 94 ),CLDL(4, 94 ) C.... CYH93... C SAVE KEMIS,IVV,IBL,ICONV,IEMIS,ITHK, CYH94 SAVE KEMIS,KALB,IEMIS,INVR,IVVA,RHMAX, SAVE INVR,IVVA,RHMAX, CTUNE1 CRH, 2 XLABDY,XLOBDY,XLIM CKC942 XLABDY,XLOBDY,XLIM,RHCLT CTUNE CYH DIMENSION CRH(3),IVV(3) CKAC DIMENSION CRH( 28 ,2) CTUNE C... ARRAY ADDED FOR RH-CL CALCULATION C INDICES FOR LON,LAT,CLD TYPE(L,M,H), LAND/SEA RESPECTIVELY C NLON=1-2, FOR EASTERN AND WESTERN HEMISPHERES C NLAT=1-4, FOR 60N-30N,30N-EQU,EQU-30S,30S-60S C LAND/SEA=1-2 FOR LAND(AND SEAICE),SEA DIMENSION RHCL (NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION RHCLA(NBIN,NLON, MCLD,NSEAL,2) DIMENSION RHCLD( 384 ,NBIN,MCLD) DIMENSION XLABDY(3),XLOBDY(3) C... XLABDY = LAT BNDRY BETWEEN TUNING REGIONS,+/- XLIM FOR TRANSITION C. XLOBDY = LON BNDRY BETWEEN TUNING REGIONS DATA XLABDY / 30. E 0 , 0. E 0 , -30. E 0 / DATA XLOBDY / 0. E 0 , 180. E 0 , 360. E 0 / DATA XLIM / 5. E 0 / CTUNE C..... INITIAL RH CRIT. SET 1 FOR OCEAN, SET 2 FOR LAND. C INVR=0 NO LAPSE RATE INVERSION TYPE CLD, =1 WIHT IT C IVVA=0 NO VERTICAL VELOCITY ADJ. FOR LOW CLD, =1 WITH ADJ. CYH93... CYH94 DATA CRH/9*0.72,7*0.70,12*0.86, 9*0.68,7*0.66,12*0.82/ CKAC DATA CRH/9*0.75 E 0,7*0.75 E 0,12*0.88 E 0, CKAC 1 9*0.70 E 0,7*0.70 E 0,12*0.85 E 0/ CYH94 DATA RHMAX/1.00/, IEMIS/1/, INVR/1/, IVVA/1/ DATA RHMAX/1.00 E 0/, INVR/1/, IVVA/1/ C DATA CRH/0.8,0.8,0.8/ C DATA IVV/1,1,0/ C DATA ISTRAT,IBL,ICONV,IEMIS,ITHK/1,1,1,0,1/ CYH93... CYH94 DATA KEMIS/0/ C.... BEGIN HERE ....... c.. C... ko3cli=0,1 for gfdl,nasa climo C.. only for ko3=1(meaning O3 is input to radfs)..see GRRAD2 ko3cli=jo3 DO 250 J=1, 384 PGR(J) = EXP(PGR(J)) SFCP(J) = PGR(J) ICNV(J) = 0. E 0 250 CONTINUE C.... C CONVERT VIRT. TEMP TO THERMODYNAMIC TEMP. C....................................................... DO 270 K=1, 28 DO 270 J=1, 384 IF(QGRS(J,K).LE.0.0 E 0) QGRS(J,K)=1.0 E -10 TGRS(J,K)=TGRS(J,K)/(1.0 E 0+0.6 E 0*QGRS(J,K)) 270 CONTINUE CTUNE XLATNH = RLAT(1) * 180. E 0 / 3.141593E+0 XLATSH = - XLATNH C.... GET RH-CLD RELATION FOR THIS LAT IREGNH = 4 DO 210 K=1,3 IF (XLATNH.GT.XLABDY(K)) THEN IREGNH = K GO TO 215 END IF 210 CONTINUE 215 IREGSH = 4 DO 220 K=1,3 IF (XLATSH.GT.XLABDY(K)) THEN IREGSH = K GO TO 225 END IF 220 CONTINUE 225 CONTINUE DO 230 ISLA=1,NSEAL DO 230 KC=1,MCLD DO 230 LO=1,NLON DO 230 NBI=1,NBIN RHCLA(NBI,LO,KC,ISLA,1) = RHCL(NBI,LO,IREGNH,KC,ISLA) RHCLA(NBI,LO,KC,ISLA,2) = RHCL(NBI,LO,IREGSH,KC,ISLA) 230 CONTINUE C..... LINEAR TRANSITION BETWEEN LATITUDINAL REGIONS... DO 240 KLA=1,3 XLNN = XLABDY(KLA)+XLIM XLSS = XLABDY(KLA)-XLIM IF (XLATNH.LT.XLNN.AND.XLATNH.GT.XLSS) THEN DO 235 ISLA=1,NSEAL DO 235 KC=1,MCLD DO 235 LO=1,NLON DO 235 NBI=1,NBIN RHCLA (NBI,LO,KC,ISLA,1) = 1 (RHCL(NBI,LO,KLA,KC,ISLA)-RHCL(NBI,LO,KLA+1,KC,ISLA)) 2 * (XLATNH-XLSS)/(XLNN-XLSS) + RHCL(NBI,LO,KLA+1,KC,ISLA) 235 CONTINUE END IF IF (XLATSH.LT.XLNN.AND.XLATSH.GT.XLSS) THEN DO 237 ISLA=1,NSEAL DO 237 KC=1,MCLD DO 237 LO=1,NLON DO 237 NBI=1,NBIN RHCLA (NBI,LO,KC,ISLA,2) = 1 (RHCL(NBI,LO,KLA,KC,ISLA)-RHCL(NBI,LO,KLA+1,KC,ISLA)) 2 * (XLATSH-XLSS)/(XLNN-XLSS) + RHCL(NBI,LO,KLA+1,KC,ISLA) 237 CONTINUE END IF 240 CONTINUE C PRINT 75,XLATNH,IREGNH,XLATSH,IREGSH C 75 FORMAT(1H ,' NH LAT AND REGION=',F7.2,I4, C 1 ' SH LAT AND REGION=',F7.2,I4) C... GET RH-CLD RELATIONSHIP FOR EACH GRID POINT, INTERPOLATING C LONGITUDINALLY BETWEEN REGIONS IF NECESSARY.. DO 248 I=1, 384 ILSEA = 1 IF (SLMSKR(I).LT.1. E 0) THEN C... OPEN OCEAN POINT.... ILSEA = 2 END IF C... WHICH HEMISPHERE IH = 1 XLONPT = DLON * (I-1) IF (I.GT. 192 ) THEN IH = 2 XLONPT = DLON * (I- 192 -1) END IF ILONGT = 1 IF (I.GT.IDTLN.AND.I.LE. 192 ) ILONGT = 2 IF (I.GT.IDTLS) ILONGT = 2 DO 246 K=1,MCLD DO 241 NBI=1,NBIN RHCLD(I,NBI,K) = RHCLA(NBI,ILONGT,K,ILSEA,IH) 241 CONTINUE IKN = 0 DO 243 KLO=1,3 DIFLO = ABS(XLONPT-XLOBDY(KLO)) IF (DIFLO.LT.XLIM) THEN IKN = KLO GO TO 244 END IF 243 CONTINUE GO TO 246 244 CONTINUE ILFT = ILONGT IRGT = ILFT + 1 IF (IRGT.GT.NLON) IRGT = 1 XLFT = XLOBDY(IKN) - XLIM XRGT = XLOBDY(IKN) + XLIM DO 245 NBI=1,NBIN RHCLD (I,NBI,K) = 1 (RHCLA(NBI,ILFT,K,ILSEA,IH)-RHCLA(NBI,IRGT,K,ILSEA,IH)) 2 * (XLONPT-XRGT)/(XLFT-XRGT)+RHCLA(NBI,IRGT,K,ILSEA,IH) 245 CONTINUE 246 CONTINUE 248 CONTINUE CTUNE C....................................................... C.... GET MEAN ZENITH ANGLE FOR THIS DTSWAV-BOTH NH AND SH C START RADFS SET-UP FOR BOTH HEMISPHERES C... GET VERTICAL MOTION (CB/SEC) IN VVEL C....................................................... CALL OMEGAS( 384 , 386 , 28 , & PPHIGR(1),PLAMGR(1),WORKR,UGRS(1,1),VGRS(1,1), 2 DGRS(1,1),DEL,RRS2(LAT),VVEL,PGR(1),SL) C... GET MODEL DIAGNOSED CLDS CALL CLDJMS( 384 , 386 , 28 ,NBIN,MCLD, 1 PGR(1),QGRS(1,1),TGRS(1,1),VVEL, 2 CVR(1),CVTR(1),CVBR(1), CKAC 3 SI,SL,CRH,SLMSKR(1), 3 SI,SL, SLMSKR(1), 4 CLDSA(1,1),MTOPA(1,1),MBOTA(1,1), CTUNE5 CLDARY(1,1),IVVA,INVR,RHMAX,CLSTR(1)) CYH945 CLDARY(1,1),IVVA,INVR,RHMAX,CLSTR(1), 5 CLDARY(1,1),IVVA,INVR,RHMAX, 6 RLAT(1),RHCLD,ISTRAT) CDG3 UNPACK CLDAMT AND CONV CLDAMT FROM CLDARY..(STRATUS IS +2) CDG3 RADIATION SEES STRATIFORM OR CONVECTIVE...NOT MERGED..... CDG3 SO CLDTOT REFLECTS THIS BELOW CDG3 NOTE:CLDARY 2-4 DIGITS TO LEFT OF DECIMAL=CV CLOUD CDG3 CLDARY 1 DIGIT TO LEFT OF DECIMAL+FRACTIONAL PART=STRAT CLD CDG3 GET STRATIFORM CLD INTO CLDTOT, CONV CLD IN CLDCNV CDG3 ..ANVIL CI IS STRATIFORM, SO PLACE THE 1 LYR IN CNV ALSO CDG3 ..ICNV = CV CLOUD TOP LAYER DO 251 K=1, 28 DO 251 I=1, 384 CLDTOT(I,K) = AMOD (CLDARY(I,K),2. E 0) CLDCNV(I,K) = FLOAT(INT(CLDARY(I,K))/10)*1. E -3 IF(CLDCNV(I,K).GT.0. E 0) THEN CLDTOT(I,K) = CLDCNV(I,K) ICNV(I) = K END IF 251 CONTINUE CDG3 ..ANVIL CI PLACED INTO LAYER ABOVE CONV CLD TOP DO 252 I=1, 384 K = ICNV(I) IF (K.GT.1.AND.K.LT. 28 ) THEN CLDCNV(I,K+1) = CLDTOT(I,K+1) END IF 252 CONTINUE CTUNE CYH94... CLDPRP NOW CALLED FROM WITHIN RADFS..... CYH93... C... COMPUTE MEAN CLOUD DIAGNOSTICS + H,M,L,TOTAL CLOUD CALL CVDIAG(AVECV(1,LAT ),AVECV(1,LATCO), 1 CVR(1),CVTR(1),CVBR(1)) CALL CLDIAG(AVECLD(1,LAT ),CLDL(1,LAT ), 1 AVECLD(1,LATCO),CLDL(1,LATCO), 2 CLDSA(1,1),CLDARY(1,1)) CTOT 2 CLDSA(1,1),MTOPA(1,1),MBOTA(1,1), CTOT 3 CLDSA(1,2),MTOPA(1,2),MBOTA(1,2), CTOT 4 CLDSA(1,3),MTOPA(1,3),MBOTA(1,3)) C... CO3 .... if (ko3cli.eq.0) 1 CALL OZON2D(SL,OZONEA(1,1),PGR(1),RLAT(1),RSIN1,RCOS1,RCOS2) if (ko3cli.eq.1) CALL OZ2D(SL,OZONEA(1,1),PGR(1),RLAT(1)) CO3 .... CYH95 DO 300 K=1, 28 CYH95 DO 300 I=1, 384 CO3 OZONEA(I,K) = 0. E 0 CYH95 PPPRSA(I,K) = SL(K) * PGR(I) C 300 CONTINUE DO 340 I=1, 384 IF(SLMSKR(I).EQ.2.0 E 0) THEN TSEAR(I) = MIN(TSEAR(I),271.2 E 0) ELSE IF(SLMSKR(I).EQ.0.0 E 0) THEN TSEAR(I) = MAX(TSEAR(I),271.21 E 0) ELSE IF(SLMSKR(I).EQ.1.0 E 0 .AND. SHELGR(I).GT.0.0 E 0) 1 THEN TSEAR(I) = MIN(TSEAR(I),273.16 E 0) ENDIF 340 CONTINUE CYH95 ... THIS PART IS REMOVED, I.E. KDAPRX WILL BE ALWAYS =1 CYH95 IF (KDAPRX.EQ.0) THEN C ********************************************** C... COMPUTE COSINE SOLAR ZENITH ANGLE IF KDAPRX=0 C... DTSWAV IS SW RADIATIVE TIME STEP IN HOURS C ********************************************** CYH95 CALL ZENITH(FJD,DLT,SLAG,RLAT(1),RLON(1),WRKEMA(1), CYH951 DTSWAV, 384 ,COSZRO(1),TAUDAR(1)) CYH95 ELSE C ********************************** C... DIURNAL CYCLE APPROXIMATION C ********************************** CYH95 DO 360 I=1, 384 CYH95 TAUDAR(I) = 1. E 0 CYH95 COSZRO(I) = COSZER(I) C 360 CONTINUE CYH95 ENDIF CYH95 ... THE NEW ALBEDO SCHEME ALREADY INCLUDES SNOW ALBEDO IF (KALB .GE. 1) THEN DO I=1,256 ALBDOA(I)=0. ENDDO RETURN ENDIF CYH95 ... THE FOLLOWING IS ONLY FOR THE OLD SFC ALBEDO SCHEME C.... ************************************ C THE FOLLOWING DETERMINES SURFACE ALBEDO (ALBDOA),WHERE SNOW EXISTS. C.... ************************************ DO 380 I=1, 384 WRKEMA(I) = 0. E 0 SSNOW(I) = SHELGR(I) * 0.1 E 0 380 CONTINUE CALL ALBSNO( 384 ,LAT,JSNO, 1 ALBDOA(1),RLAT(1),ALBEDR(1),SLMSKR(1), 1 SSNOW, TGR(1), TGRS(1,1) ) C.... RETURN END SUBROUTINE GRRAD2(TGRS,QGRS,PGR,PAERR,OZONEA,ALBDOA, CYH95 SUBROUTINE GRRAD2(TGRS,QGRS,PGR,PPPRSA,OZONEA,ALBDOA, 1 SLMSKR,COSZRO,COSZDG,RLAT,TSEAR, CYH951 SLMSKR,COSZRO,COSZDG,TAUDAR,RLAT,TSEAR, 2 ALVBR,ALNBR,ALVDR,ALNDR, 3 CLDARY,CLDSA,MTOPA,MBOTA, 4 LAT,LATCO,SDEC,SOLC,RSIN1,RCOS1,RCOS2, CYH955 RADDT,DTLW,ITIMSW,ITIMLW,IPOINT,JPOINT, 5 RADDT,DTLW,ITIMSW,ITIMLW,KALB, 6 SWHR,HLWR,ZONHT,SFNSWR,SFDLWR,TSFLWR, 7 GDFVDR,GDFNDR,GDFVBR,GDFNBR) CFPP$ NOCONCUR R C.. ************************************************************ C.. * ADDED ACCUMULATION OF CLDS AND CONVECTIVE CLOUD IN DG3 * C.. * K.A.C SEPT 1994 * C.. * F3D ADDED FOR CLOUDS..MI NEW CODE=F94/SOURCE2/DIAGNEW * C.. * B KATZ + K.A.C OCT 1994 * C.. * CHANGED KENPTS TO STORE TOTAL CLOUD AND ALL LYRS * C.. * OF CLOUD...... * C.. * K.A.C. NOV94 * C.. * FIX PL1 FOR OPERATIONS, WHERE DGZ IS ON AND DG3 IS OFF, * C.. * ....NOTE DG IS ON IF EITHER DGZ OR DG3 IS ON * C.. * K.A.C. JAN94 * C.. ************************************************************ C C UPDATES MADE TO FIX THE H2D,H3D FILES...KAC AUG 90... C UPDATES MADE TO GLOOPR - CALL WRTH2D BEFORE WRTRAD (SO CTOP OK) C TO GLOOPR - SEND WORK ARRAY TO WRTH3D C TO WRTH3D - TO WRITE PROPER LAYERS OF HEAT.. C (IN WRTRAD) C UPDATES MADE TO ADD GRID POINT DIAGNOSTICS ..K.A.C...SEP 91 C TO GLOOPR - C UPDATES MADE TO PASS AND RECEIVE SIB DATA ..K.A.C...MAR 92 C TO GLOOPR - C UPDATES MADE TO FIX SW RAD DIAGNOSTICS ..K.A.C...JUN 92 C PROPER DIURNAL WEIGHTING C TO GLOOPR AND COSZMN C UPDATES MADE TO CALCULATE CLEAR-SKY "ON-THE-FLY" KAC AUG 92 C TO GLOOPR,RADFS,FST,SPA,LWR,SWR C ...FOR CLOUD FORCING.... CYH93... CYH94 NOT USE FLAG IEMIS TO CONTROL CLD EMISS. SCHEME CYH94 NOT (=0: ORIG. SCHEME, =1: TEMP. DEP. SCHEME.) C UPDATES MADE TO CALL CLD OPTICAL PROPERTY ROUTINE (CLDPRP), C TO GIVE CLD EMISSIVITY, OPTICAL DEPTH, LAYER C REFLECTANCE AND TRANSMITANCE C TO GLOOPR AND RADFS ...Y.H. ...FEB93 CYH94 CLDPRP CALLED FROM RADFS... Y.H. ...FEB94 CTUNE C UPDATES MADE TO CHANGE DEFINITION OF H,M,L DOMAINS.. C TO CLDPRP K.A.C...DEC92 + AUG93 CYH94 TO CLDPRP K.A.C...JAN94 CYH94 ..CHANGES TO CLDPRP.........Y.H...MAR94 CTUNE CYH93... CHL95 MODIFIED TO ALLOW MORE FREQUENT COMPUTATION OF SHORTWAVE FLUX CHL95 ASSUME THAT DTSWAV <= DTLWAV!!!!!.....H.-L. PAN JUL95 CYH95 MODIFIED TO USE M.D.CHOU'S SW RADIATION SCHEME, WITH C WMO AEROSOLS DISTRIBUTIONS, AND B.P.BREIGLEB'S SURFACE C ALBEDO SCHEME. ..............Y.H...SEP95 C TO GRRAD2 - CALL RDLWSW ... TO REPLACE THE OLD RADFS C USE GFDL'S LW AND CHOU'S SW C KALB=0 USE OLD SFC ALBEDO SCHEME (MATTHEWS) C =1 USE NEW SFC ALBEDO SCHEME (BREIGLEB) C ISWSRC FLAGS FOR SELECTIONS OF SW ABSORBERS C 1:AEROSOL, 2:O2, 3:CO2, 4:W.V. 5:O3 C =1: WITH THE ABSORBER, =0: WITHOUT CYH ... ENDYH C--- C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) PARAMETER (CNWATT=- 4.1855E+0 *1.E4/60.,CNPROG=1./CNWATT) C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.... DIMENSION TGRS( 386 , 28 ),QGRS( 386 , 28 ) DIMENSION PGR( 386 ) C.... DIMENSION COSZER( 384 ),COSZDG( 384 ) CSIB PARAMETER(NVRKEN= 80 + 8 * 28 ,NPTKEN= 30 ) PARAMETER(NSTKEN= 48 ) COMMON/COMGPD/ SVDATA(NVRKEN,NPTKEN,NSTKEN), 1 IGRD(NPTKEN),JGRD(NPTKEN), 2 IGRDR(NPTKEN),JGRDR(NPTKEN), 3 ITNUM,NPOINT,ISAVE,ISSHRT,ILSHRT,IKFREQ C.... DIMENSION RLAT( 384 ),SLMSKR( 384 ) C.... CLDARY CONTAINS MULTI LAYERS OF CLOUD CYH94 DIMENSION CLDARY( 384 , 28 ),CLSTR( 384 ) DIMENSION CLDARY( 384 , 28 ) CYH94 DIMENSION EMIS0( 384 ,3),TAUC0( 384 ,3) CYH93... C.... DIMENSION FLWUP( 384 ),FSWUP( 384 ),FSWDN( 384 ) DIMENSION SSWUP( 384 ),SSWDN( 384 ),SLWUP( 384 ),SLWDN( 384 ) DIMENSION FLWUP0( 384 ),FSWUP0( 384 ) DIMENSION SSWUP0( 384 ),SSWDN0( 384 ),SLWDN0( 384 ) C.... CYH95 DIMENSION PPPRSA( 384 , 28 ), DIMENSION PAERR( 384 ,5), 1 OZONEA( 384 , 28 ),ALBDOA( 384 ), CTOT 2 CLDSA( 384 ,3),MTOPA( 384 ,3),MBOTA( 384 ,3), 2 CLDSA( 384 ,4),MTOPA( 384 ,3),MBOTA( 384 ,3), CYH953 COSZRO( 384 ),TAUDAR( 384 ), 3 COSZRO( 384 ), CYH944 WRKEMA( 384 ),TRADA( 384 , 28 ),TSEAR( 384 ), 4 TRADA( 384 , 28 ),TSEAR( 384 ), 5 SWHR( 384 , 28 ),HLWR( 384 , 28 ), 6 SFNSWR( 384 ),SFDLWR( 384 ),TSFLWR( 384 ) DIMENSION ZONHT( 28 , 94 ) CSIB DIMENSION ALVBR( 384 ),ALNBR( 384 ), 1 ALVDR( 384 ),ALNDR( 384 ), 2 GDFVBR( 384 ),GDFNBR( 384 ), 3 GDFVDR( 384 ),GDFNDR( 384 ) C...... DOWNWARD SW FLUXES FROM SW RAD..FOR SIB PARAMETERIZATION C .. SAVED FOR H2D FILE.... COMMON/SIBSW/ DFVBR( 384 , 47 ),DFNBR( 384 , 47 ), 1 DFVDR( 384 , 47 ),DFNDR( 384 , 47 ) CSIB C.... DIMENSION ISWSRC(NSRC) CYH93... C SAVE KO3,KEMIS,KALB,IVV,IBL,ICONV,IEMIS,ITHK CYH94 SAVE KO3,KEMIS,KALB,IEMIS CYH95 SAVE KO3, KALB SAVE KO3, ISWSRC C SAVE KO3, ISWSRC,ITM CYH93... CYH94 DATA KO3,KEMIS,KALB/0,0,0/ CO3 DATA KO3, KALB/0, 0/ CYH95 DATA KO3, KALB/1, 0/ DATA KO3, ISWSRC/1, 1,0,0,1,1/ C.... CKAC.... C IF(LAT .EQ. 2) CALL ERREXIT CYH95 ... NEW SUBROUTINE RDLWSW REPLACES RADFS TO C INVOKE GFDL LW RADIATION AND CHOU'S SW RADIATION SCHEME CYH95 CALL RADFS( 384 , 386 ,PGR(1),PPPRSA(1,1),QGRS(1,1),TGRS(1,1), CYH952 OZONEA(1,1),TSEAR(1),SLMSKR(1), CYH943 ALBDOA(1),RLAT(1),CLDSA(1,1), CYH953 ALBDOA(1),RLAT(1),CLDARY(1,1), CYH944 WRKEMA(1),MTOPA(1,1),MBOTA(1,1), CYH93... CYH944 CLDARY(1,1),IEMIS,EMIS0(1,1),TAUC0(1,1), CYH93... CYH955 COSZRO(1),TAUDAR(1), CYH946 LAT,KO3,KEMIS,KALB,IPOINT,JPOINT, CYH956 LAT,KO3, KALB,IPOINT,JPOINT, CYH957 SI,SL,ITIMSW,ITIMLW, CYH958 SWHR(1,1),HLWR(1,1), CSIB 9 FLWUP,FSWUP,FSWDN,SSWDN,SSWUP,SLWDN,SLWUP) CYH959 FLWUP,FSWUP,FSWDN,SSWDN,SSWUP,SLWDN,SLWUP, C CLR9 FLWUP0,FSWUP0,SSWDN0,SSWUP0,SLWDN0, CYH951 ALVBR(1),ALNBR(1),ALVDR(1),ALNDR(1), CYH951 GDFVBR(1),GDFNBR(1),GDFVDR(1),GDFNDR(1), CYH951 SOLC,RSIN1,RCOS1,RCOS2) CSIB CALL RDLWSW( 384 , 386 ,PGR(1),SI,SL, 1 LAT,RLAT(1),SOLC,RSIN1,RCOS1,RCOS2,SLMSKR(1), 2 QGRS(1,1),TGRS(1,1),OZONEA(1,1),TSEAR(1), 3 COSZRO(1),CLDARY(1,1),ALBDOA(1), 4 ALVBR(1),ALNBR(1),ALVDR(1),ALNDR(1),PAERR(1,1), 5 ITIMSW,ITIMLW,KO3,KALB,ISWSRC, 6 HLWR(1,1),SLWUP,SLWDN,FLWUP, 7 SWHR(1,1),SSWUP,SSWDN,FSWUP,FSWDN, 8 FLWUP0,FSWUP0,SSWDN0,SSWUP0,SLWDN0, 9 GDFVBR(1),GDFNBR(1),GDFVDR(1),GDFNDR(1)) C 9 ITM,GDFVBR(1),GDFNBR(1),GDFVDR(1),GDFNDR(1)) CYH95 ... ENDYH C... CNPROG IS CONVERSION FROM W/M**2 TO PROGTM UNITS IF(ITIMSW.EQ.1) THEN DO 400 I=1, 384 SFNSWR(I) = (SSWDN(I)-SSWUP(I))*CNPROG 400 CONTINUE ENDIF IF(ITIMLW.EQ.1) THEN DO 410 I=1, 384 SFDLWR(I) = SLWDN(I)*CNPROG TSFLWR(I) = TGRS(I,1) 410 CONTINUE ENDIF CSIB... C....... SAVE 4 COMPONENTS OF DOWNWARD SW FLUX IF(ITIMSW.EQ.1) THEN C..... ACCUMULATE FOR H2D FILE.. DO 1889 I=1, 384 DFVBR(I,LAT) = DFVBR(I,LAT) + RADDT * GDFVBR(I) DFNBR(I,LAT) = DFNBR(I,LAT) + RADDT * GDFNBR(I) DFVDR(I,LAT) = DFVDR(I,LAT) + RADDT * GDFVDR(I) DFNDR(I,LAT) = DFNDR(I,LAT) + RADDT * GDFNDR(I) 1889 CONTINUE ENDIF CSIB... C C GRID POINT MONITOR-DATA ON RADIATION GRID C IF(ISAVE.NE.0.AND.NPOINT.GT.0) THEN DO 336 IGPT=1,NPOINT IF (LAT.EQ.JGRDR(IGPT)) THEN DO 335 ID=1, 384 IF (ID.EQ.IGRDR(IGPT)) THEN SVDATA( 25,IGPT,ITNUM)= CLDSA(ID,3) SVDATA( 26,IGPT,ITNUM)= CLDSA(ID,2) SVDATA( 27,IGPT,ITNUM)= CLDSA(ID,1) SVDATA( 38,IGPT,ITNUM)= CLDSA(ID,4) IF(ISSHRT.LT.1.AND.ITIMSW.EQ.1) THEN SVDATA( 41,IGPT,ITNUM)= ID SVDATA( 42,IGPT,ITNUM)= LAT SVDATA( 43,IGPT,ITNUM)= SLMSKR(ID) SVDATA( 44,IGPT,ITNUM)= TSEAR (ID) SVDATA( 45,IGPT,ITNUM)= SSWDN(ID) SVDATA( 46,IGPT,ITNUM)= SSWUP(ID) SVDATA( 48,IGPT,ITNUM)= FSWDN(ID) SVDATA( 49,IGPT,ITNUM)= FSWUP(ID) SVDATA( 51,IGPT,ITNUM)= MTOPA(ID,3) SVDATA( 52,IGPT,ITNUM)= MTOPA(ID,2) SVDATA( 53,IGPT,ITNUM)= MTOPA(ID,1) SVDATA( 54,IGPT,ITNUM)= MBOTA(ID,3) SVDATA( 55,IGPT,ITNUM)= MBOTA(ID,2) SVDATA( 56,IGPT,ITNUM)= MBOTA(ID,1) SVDATA( 57,IGPT,ITNUM)= COSZRO(ID) SVDATA( 58,IGPT,ITNUM)= ASIN(SDEC)*180. E 0/3.14159265 E 0 SVDATA( 70,IGPT,ITNUM)= FLWUP0(ID) SVDATA( 71,IGPT,ITNUM)= SLWDN0(ID) IF (COSZRO(ID).GT.0.) THEN SVDATA( 72,IGPT,ITNUM)= FSWUP0(ID)*COSZDG(ID)/COSZRO(ID) SVDATA( 73,IGPT,ITNUM)= SSWDN0(ID)*COSZDG(ID)/COSZRO(ID) SVDATA( 74,IGPT,ITNUM)= SSWUP0(ID)*COSZDG(ID)/COSZRO(ID) ELSE SVDATA( 72,IGPT,ITNUM)=0. SVDATA( 73,IGPT,ITNUM)=0. SVDATA( 74,IGPT,ITNUM)=0. ENDIF ENDIF IF(ISSHRT.LT.1.AND.ITIMLW.EQ.1) THEN SVDATA( 47,IGPT,ITNUM)= SLWDN(ID) SVDATA( 50,IGPT,ITNUM)= FLWUP(ID) ENDIF IF (ILSHRT.LT.1.AND.ITIMSW.EQ.1) THEN DO 345 KC=1, 28 CVCL = FLOAT(INT(CLDARY(ID,KC))/10)*1. E -3 IF (CVCL.GT.0.0 E 0) THEN SVDATA(KC+ 80 +7* 28 ,IGPT,ITNUM) = CVCL ELSE SVDATA(KC+ 80 +7* 28 ,IGPT,ITNUM) = 1 AMOD(CLDARY(ID,KC),2. E 0) END IF 345 CONTINUE ENDIF ENDIF 335 CONTINUE ENDIF 336 CONTINUE ENDIF C....... SAVE GRIDDED RADIATIVE FLUXES AND CLD DATA IF(ITIMSW.EQ.1) THEN DO 420 I=1, 384 FLUXR(I,LAT,17) = FLUXR(I,LAT,17) + RADDT * ALBDOA(I) FLUXR(I,LAT,26) = FLUXR(I,LAT,26) + RADDT * CLDSA(I,4) 420 CONTINUE ENDIF IF(ITIMLW.EQ.1) THEN DO I = 1, 384 FLUXR(I,LAT,1 ) = FLUXR(I,LAT,1 ) + DTLW * FLWUP(I) FLUXR(I,LAT,19) = FLUXR(I,LAT,19) + DTLW * SLWDN(I) FLUXR(I,LAT,20) = FLUXR(I,LAT,20) + DTLW * SLWUP(I) FLUXR(I,LAT,21) = FLUXR(I,LAT,21) + DTLW * FLWUP0(I) FLUXR(I,LAT,25) = FLUXR(I,LAT,25) + DTLW * SLWDN0(I) ENDDO ENDIF CSWDG PROPER DIURNAL SW WGT..COSZRO=MEAN COSZ OVER DAYLIGHT, WHILE C COSZDG= MEAN COSZ OVER ENTIRE INTERVAL DO 3420 I=1, 384 IF (COSZRO(I).GT.0.) THEN FLUXR(I,LAT,2 ) = FLUXR(I,LAT,2 ) + RADDT * FSWUP(I) 1 * COSZDG(I)/COSZRO(I) FLUXR(I,LAT,3 ) = FLUXR(I,LAT,3 ) + RADDT * SSWUP(I) 1 * COSZDG(I)/COSZRO(I) FLUXR(I,LAT,4 ) = FLUXR(I,LAT,4 ) + RADDT * SSWDN(I) 1 * COSZDG(I)/COSZRO(I) FLUXR(I,LAT,18) = FLUXR(I,LAT,18) + RADDT * FSWDN(I) 1 * COSZDG(I)/COSZRO(I) FLUXR(I,LAT,22) = FLUXR(I,LAT,22) + RADDT * FSWUP0(I) 1 * COSZDG(I)/COSZRO(I) FLUXR(I,LAT,23) = FLUXR(I,LAT,23) + RADDT * SSWDN0(I) 1 * COSZDG(I)/COSZRO(I) FLUXR(I,LAT,24) = FLUXR(I,LAT,24) + RADDT * SSWUP0(I) 1 * COSZDG(I)/COSZRO(I) END IF 3420 CONTINUE C... SAVE CLD FRAC,TOPLYR,BOTLYR AND TOP TEMP C... NOTE THAT ORDER OF HIGH, MIDDLE AND LOW CLOUDS IS C... REVERSED FOR PROPER OUTPUT TO SFLUX AND H2D FILES. DO 440 K=1,3 DO 440 I=1, 384 FLUXR(I,LAT,8-K) = FLUXR(I,LAT,8-K) + RADDT * CLDSA(I,K) CPRS ..........SAVE INTERFACE PRESSURE (CB) OF TOP/BOT, ITOP = MTOPA(I,K) IBTC = MBOTA(I,K) FLUXR(I,LAT,11-K) = FLUXR(I,LAT,11-K) + RADDT * 1 SI(ITOP+1) * PGR(I) 2 * CLDSA(I,K) FLUXR(I,LAT,14-K) = FLUXR(I,LAT,14-K) + RADDT * 1 SI(IBTC) * PGR(I) 2 * CLDSA(I,K) FLUXR(I,LAT,17-K) = FLUXR(I,LAT,17-K) + RADDT * 1 TGRS(I,ITOP) * CLDSA(I,K) CLYR ...TO SAVE TOP+BOT CLD SIG LYR (UNCOMMENT THE FOLLOWING) CLYR FLUXR(I,LAT,11-K) = FLUXR(I,LAT,11-K) + RADDT * CLYR 1 MTOPA(I,K) * CLDSA(I,K) CLYR FLUXR(I,LAT,14-K) = FLUXR(I,LAT,14-K) + RADDT * CLYR 1 MBOTA(I,K) * CLDSA(I,K) 440 CONTINUE DO 450 K=1, 28 DO 450 I=1, 384 TRADA(I,K)= 0. E 0 450 CONTINUE IF(ITIMSW.EQ.1) THEN DO 460 K=1, 28 DO 460 I=1, 384 TRADA(I,K)= TRADA(I,K)+SWHR(I,K) 460 CONTINUE ENDIF IF(ITIMLW.EQ.1) THEN DO 480 K=1, 28 DO 480 I=1, 384 TRADA(I,K)= TRADA(I,K)+HLWR(I,K) 480 CONTINUE ENDIF CKAC.... CALL ZONGRD(TRADA(1,1),ZONHT(1,LAT ),ZONHT(1,LATCO)) C.... RETURN END SUBROUTINE GWAVE(RHOUR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GWAVE INTERFACE TO WAVE MODEL. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-12-18 C C ABSTRACT: THE WAVE MODEL IS INVOKED IF THE PARAMETER DTWAVE > 0 AND C THE STRESSES HAVE BEEN ACCUMULATING FOR DTWAVE HOURS. C THEN THE LAND-SEA MASK AND STRESSES ARE INTERPOLATED C TO THE WAVE GRID AND THE WAVE MODEL IS CALLED. C THE STRESSES ARE RESET FOR ACCUMULATING AGAIN. C THE WAVE MODEL IS COUPLED IF THE PARAMETER COWAVE > 0. C THEN THE ROUGHNESS GENERATED BY THE WAVE MODEL IS C INTERPOLATED BACK TO THE MODEL PHYSICS GRID. C C PROGRAM HISTORY LOG: C 91-12-18 MARK IREDELL C C USAGE: CALL GWAVE (RHOUR) C INPUT ARGUMENT LIST: C RHOUR - CURRENT FORECAST HOUR C C SUBPROGRAMS CALLED: C FLIP1 - TRANSFORM FIELD TO NEW STARTING LONGITUDE C FLIP2 - TRANSFORM FIELD TO REVERSE LATITUDE ORDER C GG2LL - INTERPOLATE GAUSSIAN GRID TO LAT-LON GRID C LL2GG - INTERPOLATE LAT-LON GRID TO GAUSSIAN GRID C ROWSEP - SEPARATE LONGITUDES IN GAUSSIAN GRID C ROW1NS - CONCATENATE LONGITUDES IN GAUSSIAN GRID C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ C................................................................. C................BEGIN TWOLOOP(COMFIBM)........................ C.... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.................SOF TWOLOOP(COMFIBM)........................ C................................................................ PARAMETER(NCPUS=1) C-WAV COMMON/COMWAV/ HSTR,USTRGG( 384 , 47 ),VSTRGG( 384 , 47 ) C-WAV COMMON /BLOCK2/ ISTEP,KPOINT,KSTEP1,KSTEP2,KWAX,LAT,LLAT,LONG,LNP C-WAV$ ,MLAT,ZM,DH,QSTART,QSTEP1,Q11OUT,Q12OUT, MARCH,QINIT C-WAV EXTERNAL FFAC C-WAV INTEGER ZM,DH C-WAV LOGICAL QINIT C-WAV PARAMETER(LONB2= 384 ,LATB2= 47 ,LONB=LONB2/2,LATB=LATB2*2) C-WAV PARAMETER(IWAVE=144,JWAVE=73,I1=11,I2=IWAVE+2-I1,J1=9,J2=67) C-WAV DIMENSION SMSKGG(LONB2,LATB2),ZORLGG(LONB2,LATB2) C-WAV DIMENSION SMSKLL(IWAVE,JWAVE),ZORLLL(IWAVE,JWAVE) C-WAV DIMENSION USTRLL(IWAVE,JWAVE),VSTRLL(IWAVE,JWAVE) C-WAV LOGICAL LMSKLL(IWAVE,JWAVE) C-WAV SAVE LMSKLL,ZORLLL C-WAV DATA IONCE/0/ C-WAV DATA SLCUT/0.75/,ZORLFL/0.01/,ZORLMX/0.2/ C----------------------------------------------------------------------- C-WAV DTW=RHOUR-HSTR C-WAV IF(LASTEP.OR.DTW.GT.DTWAVE-0.5*DELTIM/3600.) THEN C INTERPOLATE SEA-LAND MASK AND ROUGHNESS C-WAV IF(IONCE.EQ.0) THEN C-WAV IONCE=1 C-WAV DO 10 J=1,LATB2 C-WAV DO 10 I=1,LONB2 C-WAV SMSKGG(I,J)=MIN(SLMSK(I,J),1.) C-WAV IF(SLMSK(I,J).EQ.0.) THEN C-WAV ZORLGG(I,J)=ZORL(I,J) C-WAV ELSE C-WAV ZORLGG(I,J)=ZORLFL C-WAV ENDIF 10 CONTINUE C-WAV CALL ROWSEP(SMSKGG) C-WAV CALL GG2LL(NCPUS,COLRAB,LONB,LATB,SMSKGG,IWAVE,JWAVE,SMSKLL) C-WAV CALL FLIP1(I1,IWAVE,JWAVE,SMSKLL) C-WAV CALL FLIP2(IWAVE,JWAVE,SMSKLL) C-WAV DO 20 J=1,JWAVE C-WAV DO 20 I=1,IWAVE C-WAV LMSKLL(I,J)=J.GE.J1.AND.J.LE.J2.AND.SMSKLL(I,J).LT.SLCUT 20 CONTINUE C-WAV CALL ROWSEP(ZORLGG) C-WAV CALL GG2LL(NCPUS,COLRAB,LONB,LATB,ZORLGG,IWAVE,JWAVE,ZORLLL) C-WAV CALL FLIP1(I1,IWAVE,JWAVE,ZORLLL) C-WAV CALL FLIP2(IWAVE,JWAVE,ZORLLL) C-WAV ENDIF C INTERPOLATE STRESSES C-WAV CALL ROWSEP(USTRGG) C-WAV CALL GG2LL(NCPUS,COLRAB,LONB,LATB,USTRGG,IWAVE,JWAVE,USTRLL) C-WAV CALL FLIP1(I1,IWAVE,JWAVE,USTRLL) C-WAV CALL FLIP2(IWAVE,JWAVE,USTRLL) C-WAV CALL ROWSEP(VSTRGG) C-WAV CALL GG2LL(NCPUS,COLRAB,LONB,LATB,VSTRGG,IWAVE,JWAVE,VSTRLL) C-WAV CALL FLIP1(I1,IWAVE,JWAVE,VSTRLL) C-WAV CALL FLIP2(IWAVE,JWAVE,VSTRLL) C NORMALIZE STRESSES C-WAV RTIME=1./(3600.*DTW) C-WAV DO 30 J=1,JWAVE C-WAV DO 30 I=1,IWAVE C-WAV USTRLL(I,J)=USTRLL(I,J)*RTIME C-WAV VSTRLL(I,J)=VSTRLL(I,J)*RTIME 30 CONTINUE C INVOKE WAVE MODEL C-WAV QINIT=LASTEP C-WAV IYMDH=1000000*IDATE(4)+10000*IDATE(2)+100*IDATE(3)+IDATE(1) C-WAV PRINT 930,IYMDH,RHOUR,HSTR C-WAV CALL WAVE(IYMDH,HSTR,DTW,USTRLL(1,J1),VSTRLL(1,J1),LMSKLL(1,J1), C-WAV& ZORLLL(1,J1)) C INTERPOLATE ROUGHNESS C-WAV IF(COWAVE.GT.0.) THEN C-WAV DO 40 J=1,JWAVE C-WAV DO 40 I=1,IWAVE C-WAV IF(.NOT.LMSKLL(I,J).OR.ZORLLL(I,J).GT.ZORLMX) C-WAV& ZORLLL(I,J)=ZORLFL 40 CONTINUE C-WAV CALL FLIP1(I2,IWAVE,JWAVE,ZORLLL) C-WAV CALL FLIP2(IWAVE,JWAVE,ZORLLL) C-WAV CALL LL2GG(NCPUS,COLRAB,IWAVE,JWAVE,ZORLLL,LONB,LATB,ZORLGG) C-WAV CALL ROW1NS(ZORLGG) C-WAV DO 50 J=1,LATB2 C-WAV DO 50 I=1,LONB2 C-WAV IF(SLMSK(I,J).EQ.0.) ZORL(I,J)=ZORLGG(I,J) 50 CONTINUE C-WAV CALL FLIP1(I1,IWAVE,JWAVE,ZORLLL) C-WAV CALL FLIP2(IWAVE,JWAVE,ZORLLL) C-WAV PRINT 950 C-WAV ENDIF C INITIALIZE STRESSES C-WAV HSTR=RHOUR C-WAV DO 60 J=1,LATB2 C-WAV DO 60 I=1,LONB2 C-WAV USTRGG(I,J)=0. C-WAV VSTRGG(I,J)=0. 60 CONTINUE C-WAV ENDIF C----------------------------------------------------------------------- RETURN 930 FORMAT(' WAVE MODEL CALLED FOR DATE ',I8,F8.1,' FROM',F8.1) 950 FORMAT(' WAVE MODEL ROUGHNESS USED ',I8,F8.1) END SUBROUTINE GG2LL(NCPU,CGG,IN,JN,FN,IO,JO,FO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GG2LL INTERPOLATE GAUSSIAN TO LAT-LON GRID. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-12-18 C C ABSTRACT: A HORIZONTAL FIELD IS LINEARLY INTERPOLATED C FROM A GAUSSIAN GRID TO A LATITUDE-LONGITUDE GRID. C THE GAUSSIAN COLATITUDES MUST BE PASSED. C BOTH INPUT AND OUTPUT FIELDS MUST RUN FIRST EASTWARD C THEN SOUTHWARD AND START AT THE SAME LONGITUDE. C C PROGRAM HISTORY LOG: C 91-12-18 MARK IREDELL C C USAGE: CALL GG2LL(CGG,IN,JN,FN,IO,JO,FO) C INPUT ARGUMENT LIST: C CGG - JN/2 GAUSSIAN COLATITUDES IN RADIANS C IN - INPUT LONGITUDE (FIRST) DIMENSION C JN - OUTPUT LATITUDE (SECOND) DIMENSION C FN - FIELD TO INTERPOLATE C IO - OUTPUT LONGITUDE (FIRST) DIMENSION C JO - OUTPUT LATITUDE (SECOND) DIMENSION C C OUTPUT ARGUMENT LIST: C FO - INTERPOLATED FIELD C C REMARKS: THE CURRENT CODE IS OPTIMIZED FOR MULTIPROCESSING C OVER NCPU CPUS ON THE CRAY. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ C-WAV PARAMETER(PI=3.141593) C-WAV DIMENSION CGG(*),FN(IN,JN),FO(IO,JO) C-WAV DIMENSION CN(JN),CO(JO) C C-WAV JGG=JN C-WAV DO 10 J=1,JGG/2 C-WAV CN(J)=CGG(J) 10 CONTINUE C-WAV DO 20 J=JGG/2+1,JGG C-WAV CN(J)=PI-CGG(JGG+1-J) 20 CONTINUE C-WAV JLL=JO C-WAV CF=PI/(JLL-1) C-WAV DO 30 J=1,JLL C-WAV CO(J)=CF*(J-1) 30 CONTINUE C C-WAV XF=FLOAT(IN)/FLOAT(IO) C$DOACROSS SHARE(NCPU,JO,JN,CO,CN,IO,IN,FO,FN,XF), C$& LOCAL(N,J1,J2,J,WJ1,WJ2,I,X,I1,I2,WI1,WI2) CMIC$ DO ALL SHARED(NCPU,JO,JN,CO,CN,IO,IN,FO,FN,XF) CMIC$1 PRIVATE(N,J1,J2,J,WJ1,WJ2,I,X,I1,I2,WI1,WI2) DO 60 N=1,NCPU C-WAV J1=1 C-WAV J2=2 C-WAV DO 60 J=(N-1)*JO/NCPU+1,MIN(N*JO/NCPU,JO) 40 CONTINUE C-WAV IF(CO(J).GT.CN(J2).AND.J2.LT.JN) THEN C-WAV J1=J2 C-WAV J2=J2+1 C-WAV GOTO 40 C-WAV ENDIF C-WAV WJ1=(CN(J2)-CO(J))/(CN(J2)-CN(J1)) C-WAV WJ2=1.-WJ1 C-WAV DO 50 I=1,IO C-WAV X=XF*(I-1)+1. C-WAV I1=X C-WAV I2=MOD(I1,IN)+1 C-WAV WI2=X-I1 C-WAV WI1=1.-WI2 C-WAV FO(I,J)=WJ1*(WI1*FN(I1,J1)+WI2*FN(I2,J1)) C-WAV& +WJ2*(WI1*FN(I1,J2)+WI2*FN(I2,J2)) 50 CONTINUE 60 CONTINUE RETURN END SUBROUTINE LL2GG(NCPU,CGG,IN,JN,FN,IO,JO,FO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: LL2GG INTERPOLATE LAT-LON TO GAUSSIAN GRID. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-12-18 C C ABSTRACT: A HORIZONTAL FIELD IS LINEARLY INTERPOLATED C FROM A LATITUDE-LONGITUDE GRID TO A GAUSSIAN GRID. C THE GAUSSIAN COLATITUDES MUST BE PASSED. C BOTH INPUT AND OUTPUT FIELDS MUST RUN FIRST EASTWARD C THEN SOUTHWARD AND START AT THE SAME LONGITUDE. C C PROGRAM HISTORY LOG: C 91-12-18 MARK IREDELL C C USAGE: CALL LL2GG(CGG,IN,JN,FN,IO,JO,FO) C INPUT ARGUMENT LIST: C CGG - JN/2 GAUSSIAN COLATITUDES IN RADIANS C IN - INPUT LONGITUDE (FIRST) DIMENSION C JN - OUTPUT LATITUDE (SECOND) DIMENSION C FN - FIELD TO INTERPOLATE C IO - OUTPUT LONGITUDE (FIRST) DIMENSION C JO - OUTPUT LATITUDE (SECOND) DIMENSION C C OUTPUT ARGUMENT LIST: C FO - INTERPOLATED FIELD C C REMARKS: THE CURRENT CODE IS OPTIMIZED FOR MULTIPROCESSING C OVER NCPU CPUS ON THE CRAY. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ C-WAV PARAMETER(PI=3.141593) C-WAV DIMENSION CGG(*),FN(IN,JN),FO(IO,JO) C-WAV DIMENSION CN(JN),CO(JO) C C-WAV JGG=JO C-WAV DO 10 J=1,JGG/2 C-WAV CO(J)=CGG(J) 10 CONTINUE C-WAV DO 20 J=JGG/2+1,JGG C-WAV CO(J)=PI-CGG(JGG+1-J) 20 CONTINUE C-WAV JLL=JN C-WAV CF=PI/(JLL-1) C-WAV DO 30 J=1,JLL C-WAV CN(J)=CF*(J-1) 30 CONTINUE C C-WAV XF=FLOAT(IN)/FLOAT(IO) C$DOACROSS SHARE(NCPU,JO,JN,CO,CN,IO,IN,FO,FN,XF), C$& LOCAL(N,J1,J2,J,WJ1,WJ2,I,X,I1,I2,WI1,WI2) CMIC$ DO ALL SHARED(NCPU,JO,JN,CO,CN,IO,IN,FO,FN,XF) CMIC$1 PRIVATE(N,J1,J2,J,WJ1,WJ2,I,X,I1,I2,WI1,WI2) DO 60 N=1,NCPU C-WAV J1=1 C-WAV J2=2 C-WAV DO 60 J=(N-1)*JO/NCPU+1,MIN(N*JO/NCPU,JO) 40 CONTINUE C-WAV IF(CO(J).GT.CN(J2).AND.J2.LT.JN) THEN C-WAV J1=J2 C-WAV J2=J2+1 C-WAV GOTO 40 C-WAV ENDIF C-WAV WJ1=(CN(J2)-CO(J))/(CN(J2)-CN(J1)) C-WAV WJ2=1.-WJ1 C-WAV DO 50 I=1,IO C-WAV X=XF*(I-1)+1. C-WAV I1=X C-WAV I2=MOD(I1,IN)+1 C-WAV WI2=X-I1 C-WAV WI1=1.-WI2 C-WAV FO(I,J)=WJ1*(WI1*FN(I1,J1)+WI2*FN(I2,J1)) C-WAV& +WJ2*(WI1*FN(I1,J2)+WI2*FN(I2,J2)) 50 CONTINUE 60 CONTINUE RETURN END CFPP$ SKIP R SUBROUTINE FLIP1(I1,IM,JM,F) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FLIP1 TRANSFORM TO NEW STARTING LONGITUDE. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-12-18 C C ABSTRACT: A HORIZONTAL FIELD IS TRANSFORMED BY STARTING ITS INDEXING C AT A NEW LONGITUDE. C C PROGRAM HISTORY LOG: C 91-12-18 MARK IREDELL C C USAGE: CALL FLIP1(I1,IM,JM,F) C INPUT ARGUMENT LIST: C I1 - LONGITUDE INDEX OF INPUT FIELD C AT WHICH TO START OUTPUT FIELD C IM - LONGITUDE (FIRST) DIMENSION C JM - LATITUDE (SECOND) DIMENSION C F - FIELD TO TRANSFORM C C OUTPUT ARGUMENT LIST: C F - TRANSFORMED FIELD C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ C-WAV DIMENSION F(IM,JM),F1(IM) C$DOACROSS SHARE(I1,IM,JM,F),LOCAL(I,J,F1) CMIC$ DO ALL SHARED(I1,IM,JM,F) PRIVATE(I,J,F1) DO 30 J=1,JM C-WAV DO 10 I=1,IM C-WAV F1(I)=F(MOD(I+I1-2,IM)+1,J) 10 CONTINUE C-WAV DO 20 I=1,IM C-WAV F(I,J)=F1(I) 20 CONTINUE 30 CONTINUE RETURN END CFPP$ SKIP R SUBROUTINE FLIP2(IM,JM,F) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FLIP2 REVERSE LATITUDE ORDER. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-12-18 C C ABSTRACT: A HORIZONTAL FIELD IS TRANSFORMED BY REVERSING ITS INDEXING C IN LATITUDE. C C PROGRAM HISTORY LOG: C 91-12-18 MARK IREDELL C C USAGE: CALL FLIP2(IM,JM,F) C INPUT ARGUMENT LIST: C IM - LONGITUDE (FIRST) DIMENSION C JM - LATITUDE (SECOND) DIMENSION C F - FIELD TO TRANSFORM C C OUTPUT ARGUMENT LIST: C F - TRANSFORMED FIELD C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ C-WAV DIMENSION F(IM,JM) C$DOACROSS SHARE(IM,JM,F),LOCAL(I,J,F1) CMIC$ DO ALL SHARED(IM,JM,F) PRIVATE(I,J,F1) DO 20 J=1,JM/2 C-WAV DO 10 I=1,IM C-WAV F1=F(I,J) C-WAV F(I,J)=F(I,JM+1-J) C-WAV F(I,JM+1-J)=F1 10 CONTINUE 20 CONTINUE RETURN END CFPP$ NOCONCUR R SUBROUTINE GWDPS(IMX2,IMX22,KMX,A,B, 1 U1,V1,T1,Q1, 2 PSTAR, 3 SI,DEL,CL,SL,RCL,DELTIM,LAT,KDT,HPRIME, 4 DUSFC,DVSFC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GWDPS INCLUDES GRAVITY WAVE DRAG. C PRGMMR: JORDAN C. ALPERT ORG: W/NMC23 DATE: 91-03-12 C C ABSTRACT: USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- C GFDL TECHNIQUE, THE TIME TENDENCIES OF U V C ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED C GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING C CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF C CRITICAL LEVELS. C C PROGRAM HISTORY LOG: C 87-06-03 JORDAN C. ALPERT FR30(V3H-MX) C C USAGE: CALL GWDPS(A,B,U1,V1,T1,Q1,PSTAR, C SI,DEL,CL,SL,RCL,DELTIM,LAT,KDT,HPRIME) C INPUT ARGUMENT LIST: C A - NEGATIVE NON-LIN TENDENCY FOR V WIND COMPONENT. C B - NON-LIN TENDENCY FOR U WIND COMPONENT. C U1 - ZONAL WIND COMPONENT *COS(LAT) M/SEC AT T0-DT. C V1 - MERIDIONAL WIND COMPONENT *COS(LAT) M/SEC AT T0-DT. C T1 - TEMPERATURE DEG K AT T0-DT. C Q1 - SPECIFIC HUMIDITY AT T0-DT. C PSTAR - SURFACE PRESSURE (CB). C SI(N) - P/PSFC AT BASE OF LAYER N. C DEL(N) - POSITIVE INCREMENT OF P/PSFC ACROSS LAYER N. C CL(N) = 1 - SL(N). C SL(N) - P/PSFC AT MIDDLE OF LAYER N. C RCL - RECIPROCAL OF SQUARE OF COS(LAT). C DELTIM - TIME STEP SECS. C LAT - LATITUDE NUMBER. C KDT - TIME STEP NUMBER. C HPRIME - TOPOGRAPHIC STANDARD DEVIATION (M). C C OUTPUT ARGUMENT LIST: C A - AS AUGMENTED BY TENDENCY DUE TO MIGWD. C B - AS AUGMENTED BY TENDENCY DUE TO MIGWD. C C OUTPUT FILES: C FT06F001 - PRINTOUT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN, CFT77. C MACHINE: CRAY Y-MP. C C$$$ C DIMENSION A(IMX2,KMX), B(IMX2,KMX), 2 U1(IMX22,KMX), V1(IMX22,KMX),HPRIME(IMX2), 3 T1(IMX22,KMX), Q1(IMX22,KMX),PSTAR(IMX2), 7 SI(KMX+1),DEL(KMX),CL(KMX),SL(KMX) DIMENSION DUSFC(IMX2),DVSFC(IMX2) C PARAMETER(CP= 1.0046E+3 ,G= 9.8000E+0 ,RD= 2.8705E+2 ,RV= 4.6150E+ 12 ) PARAMETER(GOR=G/RD,GOCP=G/CP,FV=RV/RD-1) PARAMETER(DW2MIN=1.,RIMIN=-100.) C C LOCAL ARRAY LOGICAL LDRAG( 384 ) DIMENSION RDZT( 28 -1) DIMENSION VELCO( 384 , 28 -1) C C DEBUG DIMENSION C DIMENSION RI( 28 -1) C C---- MOUNTAIN INDUCED GRAVITY WAVE DRAG C---- UNIT14 - SUBGRID SCALE MOUNTAIN VARIANCE HEIGHT INPUT C---- COMMON TO BE ADDED TO SMF,GLOO FOR MIGWD *J* C---- IDIMT = 256 AND KDIM = 18 FOR EXAMPLE... C D I M E N S I O N .TAUB( 384 ),XN( 384 ),YN( 384 ),DTAUX( 384 , 28 ), .UBAR( 384 ),VBAR( 384 ),TAUD( 384 , 28 ),FR( 384 ),GF( 384 ), .ULOW( 384 ),BNV( 384 ),VTJ( 384 , 28 ),DTAUY( 384 , 28 ), .BNV2( 384 , 28 ),SIGK( 28 ), .TAUP( 384 , 28 +1),USQJ( 384 , 28 ), .RO( 384 , 28 ),ROLL( 384 ) DIMENSION DTFAC( 384 ) DIMENSION VELKO( 28 -1) REAL AKAPPA REAL SLREAL C HMHJ IDIMT=IMX2 IDIMT2=IMX22 KDIM=KMX C C C--------------------------------------------CONSTANTS FOR MIGWD *J* C C-----ONLY DO CONSTANTS FIRST TIME THROUGH MONNIN C RLOWLV =0.7 XL =4.0 E 4 CRITAC =5.0 E -4 NCNT =100 C AKAPPA = 2. / 7. C DO 18 K=1,KDIM SLREAL = SL(K) SIGK(K) = SLREAL**(-AKAPPA) 18 CONTINUE C C------- MKDIMP THE TOP SIGMA LEVEL OVER WHICH MIGWD WILL OPERATE C MKDIMP = KDIM+1 C C------- KBJ IS THE BOTTOM OF THE LOW 1/3 LEVEL USUALLY = 1 C KBJ = 1 DO 15 K = KBJ, KDIM IF (SI(K) .LT. RLOWLV) THEN KSM = K GO TO 16 ENDIF 15 CONTINUE 16 CONTINUE C C-----KSM -1 INTERVALS IN THE LOWER THIRD OF ATM (SIGMA < .667) C KSMM1 = KSM - 1 DELKS = SI(KBJ)-SI(KSM) DELKS1=SL(KBJ)-SL(KSM) C C----ABOVE, THE LOW LAYER DELTA SIGMA C-----BELOW THE STARTING SIGMA LEVEL FOR PS STRESS CALC DEFAULTS TO 2 C KBPS = 2 LCAP=KDIM LCAPP1 = LCAP + 1 FACTOP=0.5 C GRAV = G GRAV2 = GRAV * GRAV RGAS = RD GR2 = 2.0 * GRAV2 / RGAS GMAX = 1. AJ = 1. XLINV = 1.0 / XL VELEPS=1.0 RCS=SQRT(RCL) CS = 1. / RCS C C----------SAVING RICHARDSON NUMBER IN USQJ FOR MIGWD *J* C DO K=1,KDIM-1 RDZT(K)=GOR*SI(K+1)/(SL(K)-SL(K+1)) ENDDO DO K=1,KDIM DO J=1,IDIMT VTJ(J,K)=T1(J,K)*(1.+FV*Q1(J,K)) ENDDO ENDDO DO K=1,KDIM-1 DO J=1,IDIMT TI=0.5*(T1(J,K)+T1(J,K+1)) RDZ=RDZT(K)/TI DW2=RCL*((U1(J,K)-U1(J,K+1))**2+(V1(J,K)-V1(J,K+1))**2) SHR2=MAX(DW2,DW2MIN)*RDZ**2 BVF2=G*(GOCP+RDZ*(VTJ(J,K+1)-VTJ(J,K)))/TI USQJ(J,K)=MAX(BVF2/SHR2,RIMIN) ENDDO ENDDO C C-----VERTICAL STRUCTURE OF RI IN RI(KDIM) FOR DIAGNOSTICS C C-----THE LINEAR MOUNTAIN INDUCED GRAVITY MODE P&S PRAMETERIZATION C EXPLITLY DONE C-----THIS ROUTINE COMPUTES THE DECELERATION OF THE ZONAL WIND AND C-----MERIDIONAL WIND DUE TO MOUNTAIN GRAVITY DRAG. C C----- CODE VARIABLES DESCRIPTION C C----- XN,YN PROJECTIONS OF "LOW-LEVEL" WIND C----- IN ZONAL & MERIDIONAL DIRECTIONS C C----- ULOW "LOW-LEVEL" WIND MAGNITUDE - (= U) C----- AVERAGED UP TO 2KM ABOVE SURFACE C C----- BNV2 BNV2 = N**2 C C----- HPRIME SUB-GRID SCALE MOUNTAIN HEIGHT (= H) C----- FROM NAVY TAPE, AVERAGED,'ENVELOPE'STD. VA C----- READ IN IN SMF,COMMON-ED TO GLOO C C----- TAUB BASE MOMENTUM FLUX C----- = -(RO * U**3/(N*XL)*GF(FR) FOR N**2 > 0 C----- = 0. FOR N**2 < 0 C C C----- FR FROUDE = N*HPRIME / U C----- G GMAX*FR**2/(FR**2+AJ**2) C----- GMAX = 1.0 C----- AJ = 1.0 C C-----KSM IS DEFINED AS THE NUMBER OF LEVELS UP 1/3 FROM THE LOWEST USED C-----TO CALCULATE THE "LOW-LEVEL" AVERAGES. C C C-----INITIALIZE ARRAYS (ON CYBER) C DO 200 I=1,IDIMT XN(I) = 0.0 YN(I) = 0.0 UBAR (I)= 0.0 VBAR (I)= 0.0 ROLL (I)= 0.0 TAUB (I)= 0.0 ULOW (I)= 0.0 TAUP (I,KDIM+1) = 0.0 200 CONTINUE C DO 250 K=1,KDIM DO 250 I=1,IDIMT TAUP(I,K) = 0.0 RO(I,K) = SL(K) * PSTAR(I) 1 / ( RGAS * VTJ(I,K) ) 250 CONTINUE C C----DENSITY TONS/METER**3 C--------.---------.---------.---------.---------.---------.---------. . C-----COMPUTE LOW LEVEL AVERAGES C-----(U,V)*COS(LAT) USE UV=(U1,V1) WHICH IS WIND AT T0-1 C----- USE RCS=1/COS(LAT) TO GET WIND FIELD C---- KSM THE TOP OF THE LOWEST 1/3 LAYER "THE LOW LEVEL" IS 6 C DO 300 K=KBJ,KSMM1 RCSKS = RCS * DEL(K) / DELKS DO 300 I=1,IDIMT UBAR(I) = UBAR(I) + RCSKS * U1(I,K) VBAR(I) = VBAR(I) + RCSKS * V1(I,K) 300 CONTINUE C C----COMPUTE THE "LOW LEVEL" OR 1/3 WIND MAGNITUDE (M/S) C DO 400 I=1,IDIMT ULOW(I) = SQRT( UBAR(I) * UBAR(I) + VBAR(I) * VBAR(I) ) 400 CONTINUE DO 450 I=1,IDIMT VALUE = 1.0 ULOW(I) = MAX( ULOW(I), VALUE ) 450 CONTINUE C C-----CALCULATE SQUARED LOW LEVEL BRUNT VAISALA FREQUENCY OVER THE C-----FIRST KSM LEVELS THEN AVERAGE C---- SIGKM IS RECIP( SIGMA** KAPPA) AT TOP OF LOWER LAYER C---- SIGKIN IS RECIP( SIGMA** KAPPA) AT BOTTOM OF LOWER LAYER C---- RDELKS (DEL(K)/DELKS) VERT AVE FACTOR SO WE CAN * INSTEAD OF / C DO 500 I=1,IDIMT BNV2(I,1) = 0. 500 CONTINUE C DO 550 K=KBJ,KSMM1 DO 550 I=1,IDIMT BNV2(I,K) = GR2 * (SL(K) + SL(K+1)) 1 * (VTJ(I,K+1) * SIGK(K+1) - VTJ(I,K) * SIGK(K)) 2 / ( (VTJ(I,K) * SIGK(K) 3 + VTJ(I,K+1) * SIGK(K+1)) 4 * (SL(K) - SL(K+1)) 5 * (T1(I,K) + T1(I,K+1)) ) 550 CONTINUE C DO 600 K=1,KDIM-1 DO 600 I=1,IDIMT VELCO(I,K) = 1 (0.5*RCS)*( (U1(I,K) + U1(I,K+1)) * 2 UBAR(I) + 3 (V1(I,K) + V1(I,K+1)) * 4 VBAR(I)) VELCO(I,K)=VELCO(I,K)/ULOW(I) IF ((VELCO(I,K).LT.VELEPS).AND.(VELCO(I,K).GE.0.)) THEN VELCO(I,K) = VELEPS ENDIF 600 CONTINUE C C NO DRAG WHEN CRITICAL LEVEL IN THE BASE LAYER C DO 700 I=1,IDIMT LDRAG(I)=VELCO(I,1).LE.0. 700 CONTINUE DO 750 K=2,KSMM1 DO 750 I=1,IDIMT LDRAG(I)=LDRAG(I).OR. VELCO(I,K).LE.0. 750 CONTINUE C C NO DRAG WHEN BNV2.LT.0 C DO 800 K=1,KSMM1 DO 800 I=1,IDIMT LDRAG(I)=LDRAG(I).OR. BNV2(I,K).LT.0. 800 CONTINUE C C-----THE LOW LEVEL WEIGHTED AVERAGE RI IS STORED IN USQJ(1,1; IDIMT) C-----THE LOW LEVEL WEIGHTED AVERAGE N**2 IS STORED IN BNV2(1,1; IDIMT) C----- THIS IS CALLED BNVL2 IN GWDRAG NOT BNV2 C KBJP1 = KBJ + 1 WTKBJ = (SL(KBJ)-SL(KBJP1))/DELKS1 DO 900 I=1,IDIMT USQJ(I,1) = WTKBJ * USQJ(I,KBJ) BNV2(I,1) = WTKBJ * BNV2(I,KBJ) 900 CONTINUE C DO 1000 K = KBJP1,KSMM1 RDELKS = (SL(K)-SL(K+1))/DELKS1 DO 1000 I=1,IDIMT BNV2(I,1) = BNV2(I,1) + BNV2(I,K) * RDELKS USQJ(I,1) = USQJ(I,1) + USQJ(I,K) * RDELKS 1000 CONTINUE C DO 1010 I=1,IDIMT LDRAG(I)=LDRAG(I).OR. BNV2(I,1).LE.0.0 LDRAG(I)=LDRAG(I).OR. ULOW(I).EQ.1.0 1010 CONTINUE C C ----- SET ALL RI LOW LEVEL VALUES TO THE LOW LEVEL VALUE C KBJBEG = KBJ IF(KBJ .EQ. 1) KBJBEG = 2 DO 1020 K=KBJBEG,KSMM1 DO 1020 I=1,IDIMT USQJ(I,K) = USQJ(I,1) 1020 CONTINUE C C----- LOW LEVEL DENSITY C DO 1030 K=KBJ,KSMM1 RDELKS = DEL(K)/DELKS DO 1030 I=1,IDIMT ROLL(I) = ROLL(I) + RO(I,K) * RDELKS 1030 CONTINUE C DO 1050 I=1,IDIMT IF (.NOT.LDRAG(I) ) THEN C C-----VECTOR SQUARE ROOT FUNCTION - VSQRT - USED TO COMPUTE BNV C BNV(I) = SQRT( BNV2(I,1) ) C C-----CALCULATE FR FROUDE ---- N*HPRIME / U C FR(I) = BNV(I) * HPRIME(I) / ULOW(I) C C----CONTINUE W/ WHERE BLOCK C C-----CALCULATE G THE UNIVERSAL FLUX FUNCTION C GF(I) = GMAX * FR(I) * FR(I) / 1 ( FR(I) * FR(I) + AJ * AJ ) C C-----CALCULATE TAUB - (THE BASE FLUX) C-----REMEMBER - THE LOW LEVEL N IS IN BNV2(1,1;IDIMT) = BNV = BNVL2 C TAUB(I) = -XLINV * ROLL(I) * 1 ULOW(I) * ULOW(I) * ULOW(I) * GF(I) / BNV(I) C C-----CALCULATE XN, YN C XN(I) = UBAR(I) / ULOW(I) C YN(I) = VBAR(I) / ULOW(I) C ELSE C TAUB(I) = 0.0 XN(I) = 0.0 YN(I) = 0.0 C ENDIF 1050 CONTINUE C C------THE CALL TO GWDRAG: C------ TAUP ARE RETURNED OTHER PARAMETERS FROM MONN C CALL GWDRAG(IDIMT,IDIMT2,KDIM, 1 U1,V1,T1,PSTAR,VTJ,USQJ,KSM,KBJ,KBPS, 1 VELCO,BNV2,ROLL,RO,TAUB,SI,DEL,SL,SIGK,RCL, 2 LAT,KDT,HPRIME,XLINV,TAUP) C IF(LCAP.LT.KDIM) THEN C DO 1100 KLCAP = LCAPP1, KDIM C SIRA = SI(KLCAP) / SI(LCAP) C DO 1100 I=1,IDIMT TAUP(I,KLCAP) = SIRA * TAUP(I,LCAP) C 1100 CONTINUE C ENDIF C C-----FIX UP THE LEVEL 1 (OR MORE) STRESS TO BE LINEAR WITH LEVEL C-----KBPS AND THE STRESS AT THE BOTTOM TAUB (IF KBPS IS .GT. 1) C IF (KBPS .GT. KBJ) THEN KBPSM1 = KBPS - 1 KBPSP1 = KBPS + 1 C DO 1200 IK1 = KBJ, KBPSM1 SAVEM = ( (SI(IK1+1) - SI(KBPSP1)) / 1 (SI(KBPSP1) - 1.0 ) ) DO 1200 I=1,IDIMT TAUP(I,IK1+1) = TAUP(I,KBPSP1) - 1 SAVEM * ( TAUP(I,KBJ) - TAUP(I,KBPSP1) ) 1200 CONTINUE C ENDIF C C---KEEP IN MIND THAT TAUP IS ZERO-ED OUT BEFORE EACH CALL C-----VERTICALLY DIFFERENCE STRESS FOR D TAU / D SIGMA FROM SI TO SL C DO 1300 K=1,KDIM DO 1300 I=1,IDIMT C C-----THE STRESS IN GWSDRAG HAS BEEN CALC USING -TAUB WHICH NOW MUST BE C-----RETURNED TO -(AMPLITUDE) BELOW THE OLD WAY FOR TAU AS -(RO*U**3/NL C-----INSTEAD OF RO*UAMP*K*N*H'**2 C C TAUD(I,K) = (TAUP(I,K+1) - TAUP(I,K) ) / DEL(K) C C---WHERE DEL= SI(K)-SI(K+1) (SIGN 'SWITCHED' IN SELA CODE) C 1300 CONTINUE C C-----CALCULATE DECELERATION TERMS - DTAUX,DTAUY C DO 1400 K=1,KDIM DO 1400 I=1,IDIMT TAUD(I,K) = TAUD(I,K) / PSTAR(I) 1400 CONTINUE C C------LIMIT DE-ACCELERATION (MOMENTUM DEPOSITION ) AT TOP TO 1/2 VALUE C------THE IDEA IS SOME STUFF MUST GO OUT THE 'TOP' C C------LIMIT DE-ACCELERATION (MOMENTUM DEPOSITION ) AT TOP TO 1/2 VALUE C------THE IDEA IS SOME STUFF MUST GO OUT THE 'TOP' C DO 1500 KLCAP = LCAP, KDIM DO 1500 I=1,IDIMT TAUD(I,KLCAP) = TAUD(I,KLCAP) * FACTOP 1500 CONTINUE C C----- *G AND * BY COS(LAT) FOR MRF TENDENCIES C CSGRAV = CS * GRAV DO 1600 K=1,KDIM DO 1600 I=1,IDIMT TAUD(I,K) = TAUD(I,K) * CSGRAV 1600 CONTINUE C C------IF THE GRAVITY WAVE DRAG WOULD FORCE A CRITICAL LINE C------IN THE LOWER KSMM1 LAYERS DURING THE NEXT 2*DELTIM TIMESTEP, C------THEN ONLY APPLY DRAG UNTIL THAT CRITICAL LINE IS REACHED. C DO 1610 I=1,IDIMT DTFAC(I)=1. 1610 CONTINUE DO 1620 K=1,KSMM1 DO 1620 I=1,IDIMT IF(TAUD(I,K).NE.0.) &DTFAC(I)=MIN(DTFAC(I),ABS(VELCO(I,K)/(2.*DELTIM*RCS*TAUD(I,K)))) 1620 CONTINUE C DO 1625 I=1,IDIMT C IF(DTFAC(I).LT.0.20) THEN C PRINT 1624,KDT,LAT,I,DTFAC(I),VELCO(I,1),2.*DELTIM*RCS*TAUD(I,1), C & TAUB(I),BNV(I),HPRIME(I) 1624 FORMAT(' GWD KDT,LAT,I,DTFAC,V1,DV1',3I4,2PF8.1,0P2F8.2,3E12.4) C ENDIF 1625 CONTINUE DO 1630 K=1,KDIM DO 1630 I=1,IDIMT TAUD(I,K)=TAUD(I,K)*DTFAC(I) 1630 CONTINUE C C-----FOR OPERATIONS DO THIS USING A BIT VECTOR TO SELECT IN THE ABOVE C-----WHERE BLOCK AND THEN PRINT ONLY THOSE THAT ARE TRUE. C DO 1660 K=1,KDIM DO 1660 I=1,IDIMT C DTAUX(I,K) = XN(I) * TAUD(I,K) DTAUY(I,K) = YN(I) * TAUD(I,K) C 1660 CONTINUE C C MONITOR FOR EXCESSIVE GRAVITY WAVE DRAG TENDENCIES C CP IF(NCNT.GT.0) THEN CP IF(LAT.GE.38.AND.LAT.LE.42) THEN CP CMIC$ GUARD 37 CP DO 92 I=1,IDIMT CP IF(IKOUNT.GT.NCNT) GO TO 92 CP IF(I.LT.319.OR.I.GT.320) GO TO 92 CP DO 91 K=1,KDIM CP IF(ABS(RCS*TAUD(I,K)) .GT. CRITAC) THEN CP IF(I.LE.IDIM) THEN CP IKOUNT=IKOUNT+1 CP PRINT 123,I,LAT,KDT CP PRINT 124,TAUB(I),BNV(I),ULOW(I),GF(I),FR(I), CP . ROLL(I),HPRIME(I),XN(I),YN(I) CP PRINT 124,(TAUD(I,KK),KK=1,KDIM) CP PRINT 124,(TAUP(I,KK),KK=1,KDIM+1) CP PRINT 124,(USQJ(I,KK),KK=1,KDIM) CP DO 93 KK=1,KDIM-1 CP VELKO(KK)=0.5*RCS*((U1(I,KK)+U1(I,KK+1))*UBAR(I)+ CP . (V1(I,KK)+V1(I,KK+1))*VBAR(I))/ULOW(I) CP 93 CONTINUE CP PRINT 124,(VELKO(KK),KK=1,KDIM-1) CP PRINT 124,(A (I,KK),KK=1,KDIM) CP PRINT 124,(DTAUY(I,KK),KK=1,KDIM) CP PRINT 124,(B (I,KK),KK=1,KDIM) CP PRINT 124,(DTAUX(I,KK),KK=1,KDIM) CP GO TO 92 CP ENDIF CP ENDIF CP 91 CONTINUE CP 92 CONTINUE CP CMIC$ END GUARD 37 CP 123 FORMAT(' *** MIGWD PRINT *** I=',I3,' LAT=',I3,' KDT=',I3) CP 124 FORMAT(2X, 10E13.6) CP ENDIF CP ENDIF C C-----DONE WITH CALCULATION - ADD IT TO OLD A AND OLD B C-----A CORRESPONDS TO DTAUY TERM AND B TO DTAUX C DO 2001 I=1,IDIMT DUSFC(I)=0. DVSFC(I)=0. 2001 CONTINUE DO 2000 K=1,KDIM DO 2000 I=1,IDIMT A(I,K) = DTAUY(I,K) + A(I,K) B(I,K) = DTAUX(I,K) + B(I,K) DUSFC(I)=DUSFC(I)+DTAUX(I,K)*DEL(K) DVSFC(I)=DVSFC(I)+DTAUY(I,K)*DEL(K) 2000 CONTINUE DO 2002 I=1,IDIMT DUSFC(I)=-1.E3/G*RCS*PSTAR(I)*DUSFC(I) DVSFC(I)=-1.E3/G*RCS*PSTAR(I)*DVSFC(I) 2002 CONTINUE C C-----DIAGNOSTIC FLAG .NE.0 ON, OTHERWISE OFF, NUM(715)=OUTPUT UNIT (=6) C RETURN END CFPP$ NOCONCUR R SUBROUTINE GWDRAG(IMX2,IMX22,KMX, . U1,V1,T1,PSTAR,VTJ,USQJ,KSM,KBJ,KBPS, . VELCO,BNVL2,ROLL,RO,TAUB,SI,DEL,SL,SIGK,RCL, . LAT,KDT,HPRIMX,AKWNMB,TENSIO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GWDRAG PERFORMS GRAVITY WAVE DRAG COMPUTATIONS. C PRGMMR: JORDAN C. ALPERT ORG: W/NMC23 DATE: 91-03-12 C C ABSTRACT: PERFORMS GRAVITY WAVE DRAG COMPUTATIONS. C C PROGRAM HISTORY LOG: C 87-06-03 JORDAN C. ALPERT GWDRAG, GWDPS. C 89-02-01 HANN-MING HENRY JUANG CHANGE TO FORTRAN 77. C 91-03-03 SELA-ROZWODOSKI CRAY GUARD CODE AND CONSTANTS - C GGWDRA, GGWDPS. C C USAGE: CALL GWDRAG(U1,V1,T1,PSTAR,VTJ,USQJ,KSM,KBJ,KBPS, C VELCO,BNVL2,ROLL,RO,TAUB,SI,DEL,SL,SIGK,RCL, C LAT,KDT,HPRIMX,AKWNMB,TENSIO) C INPUT ARGUMENT LIST: C U1 - ZONAL WIND COMPONENT *COS(LAT) M/SEC AT T0-DT. C V1 - MERIDIONAL WIND COMPONENT *COS(LAT) M/SEC AT T0-DT. C T1 - TEMPERATURE DEG K AT T0-DT. C PSTAR - SURFACE PRESSURE (CB). C VTJ - VIRTUAL TEMPERATURE. C USQJ - RICHARDSON NUMBER. C KSM - TOP OF LOW LEVEL LAYER FOR GWDRAG SET TO 2. C KBJ - BOTTOM OF LOW LEVEL LAYER FOR GWDRAG SET TO 1. C KBPS - BOTTOM STARTING SIGMA LEVEL FOR P&S STRESS CALCULATION C SI(N) - P/PSFC AT BASE OF LAYER N. C DEL(N) - POSITIVE INCREMENT OF P/PSFC ACROSS LAYER N. C SL(N) - P/PSFC AT MIDDLE OF LAYER N. C RCL - RECIPROCAL OF SQUARE OF COS(LAT). C LAT - LATITUDE NUMBER. USED ONLY AS DIAGNOSTIC. C KDT - TIME STEP NUMBER. USED ONLY AS DIAGNOSTIC. C HPRIMX - TOPOGRAPHIC STANDARD DEVIATION (M). C C OUTPUT ARGUMENT LIST: C VELCO - COMP OF WIND ALONG THE DIRECTION OF LOW LEVEL LAYER. C BNVL2 - BRUNT-VIASILA FREQ AS (N) AND ALSO (N**2). C ROLL - LOW LEVEL RO. C RO - DENSITY MTS. C TAUB - SURFACE STRESS. C SIGK - SINGLE DIMENSION ARRAY OF LENGTH KDIM WHICH HOLDS C - THE CONSTANTS OF INVERSE SIGMA VALUES RAISED TO C - R/CP POWER FROM SUBROUTINE GGWDPS. C AKWNMB - LENGTH SCALE. C TENSIO - STRESS. C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: FORTRAN, CFT77. C MACHINE: CRAY Y-MP. C C$$$ C C G L A S M I G W D (GWDRAG) C DIMENSION . U1(IMX22,KMX),V1(IMX22,KMX),T1(IMX22,KMX), . PSTAR(IMX2),VTJ(IMX2,KMX),USQJ(IMX2,KMX), . VELCO(IMX2,KMX-1),BNVL2(IMX2),ROLL(IMX2), . RO(IMX2,KMX),TAUB(IMX2), . SI(KMX+1),DEL(KMX),SL(KMX),SIGK(KMX), . HPRIMX(IMX2),TENSIO(IMX2,KMX) C LOCAL ARRAY D I M E N S I O N . HPRIME( 384 ) ., HCO( 384 ),HSI( 384 ) ., CRIF2( 384 ),FRO2( 384 ) ., CL( 28 ),BNV2( 384 ),ULOW( 384 ) ., ZMEAN( 28 ,2) C LOGICAL ICRILV( 384 ) REAL AKAPPA C HMHJ IDIMT=IMX2 IDIMT2=IMX22 KDIM=KMX C C-----ONLY DO CONSTANTS FIRST TIME THROUGH MONNIN C C C-----GSFC TO NMC BRIDGE CONSTANTS C NTOPM1=KDIM-1 C GRAV = 9.8000E+0 GRAV2 = GRAV * GRAV AGRAV = 1./GRAV RGAS = 2.8705E+2 GR2 = 2. * GRAV2 / RGAS AKAPPA = 2. / 7. FROCUT=0.85 * 0.85 C RCS=SQRT(RCL) C C-----THE VARIANCE OF TOPOGRAPHY (COMES IN AS STD DEV) ON A LAT PAIR C DO 100 I= 1, IDIMT HPRIME(I) = HPRIMX(I) * HPRIMX(I) 100 CONTINUE C C-----CONSTRAIN VARIANCE TO BE NOT GREATER THAN 160000 M**2 C ONLY IF P&S LOW LEVEL STRESS IS USED - COMMENT FOR GFCL LOW LEV C DO 200 I=1, IDIMT VALUE = 1.6 E 5 HPRIME(I) = MIN( HPRIME(I), VALUE ) 200 CONTINUE C C-----INITIALIZE CRITICAL LEVEL CONTROL VECTOR BITS ALL TO ZERO C DO 300 I=1, IDIMT ICRILV(I) = .FALSE. 300 CONTINUE C C----BNVL2, THE LOW LEVEL BRUNT-VIASLA FREQUENCY IS NOT A FCT OF K C----SQRT (N**2) NB: I USE BNVL2 FOR N**2 AND NOW N ITSELF C DO 400 I=1,IDIMT VALUE = 0.0 BNVL2(I) = MAX( BNVL2(I) , VALUE ) BNVL2(I) = SQRT ( BNVL2(I) ) 400 CONTINUE C C-----SET INITIAL VALUES FOR STRESS C DO 500 K=1,KDIM DO 500 I=1,IDIMT TENSIO(I,K) = 0.0 500 CONTINUE C C------ LEVEL LOOP C C-----SET UP BOTTOM VALUES OF STRESS IF WE ARE NOT STARTING FROM C-----FROM LEVEL 1 - NB (-) HERE BY CONVENTION C DO 600 KLOW = 1, KBPS DO 600 I=1,IDIMT TENSIO(I,KLOW) = -1. * TAUB(I) 600 CONTINUE C DO 1100 K = KBPS, NTOPM1 C DO 1110 I=1, IDIMT FRO2(I) = 0.0 CRAY 1110 CONTINUE C C-----CALCULATE SQUARED BRUNT VAISALA FREQUENCY AT LEVEL K C---- SIGKM IS RECIP( SIGMA** KAPPA) AT TOP OF LAYER C---- SIGKIN IS RECIP( SIGMA** KAPPA) AT BOTTOM OF LAYER C SIGKM = SIGK(K+1) SIGKIN = SIGK(K) C C--- N**2 AS FUNCTION OF K - BRANCH ON LOW LEVEL MEANS STABLE (ICRILV=0) C CRAY DO 1150 I=1, IDIMT IF ( .NOT. ICRILV(I) ) THEN CRIF2(I) = 1 - .25 / USQJ(I,K) CRIF2(I) = CRIF2(I) * CRIF2(I) ELSE CRIF2(I)=0.0 ENDIF CRAY 1150 CONTINUE C C-----UNSTABLE LAYER IF UPPER AIR VEL COMP ALONG SURF VEL <=0 (CRIT LAY) C---- AT (U-C)=0. CRIT LAYER EXISTS AND BIT VECTOR SHOULD BE SET (.LE.) C CRAY DO 1160 I=1,IDIMT ICRILV(I) = ICRILV(I) .OR. VELCO(I,K) 1 .LE. 0.0 CRAY 1160 CONTINUE C C-----SQRT (N**2) NB: I USE BNV2 FOR N**2 AND NOW N ITSELF C CRAY DO 1170 I=1, IDIMT VALUE = 0. BNV2(I) = MAX( BNV2(I) , VALUE ) BNV2(I) = SQRT ( BNV2(I) ) CRAY 1170 CONTINUE 1110 CONTINUE C C-----COMPUTING STRESS AT SURFACE AND 1 LEVEL UP & LIMIT MAX VALUE C C----USING TAUB AT KBJ LEVEL C IF(K .EQ. KBJ) THEN C DO 1180 I=1, IDIMT CRIF2(I) = MIN( CRIF2(I) , FROCUT ) CRAY 1180 CONTINUE CRAY DO 1190 I=1, IDIMT IF ( .NOT. ICRILV(I) ) THEN C C-----GFDL LOW LEVEL SURFACE STRESS IS NEGITIVE WITH RESPECT TO GLAS C-----BECASUE GLAS SUBTRACTS TENDENCY WHILE MONIN ADDS WE CHANGE TAUB C-----TO -TAUB (NB BUT CHANGE BACK FOR MONIN TENDENCY C TENSIO(I,K) = -1. * TAUB(I) C C---FR**2 AT SURFACE ONLY C FRO2(I) = BNVL2(I) * BNVL2(I) * 1 HPRIME(I) / (VELCO(I,K) * VELCO(I,K)) C ENDIF CRAY 1190 CONTINUE 1180 CONTINUE C ELSE C C-----IN GLAS VERSION THERE IS A CALCULATION AT THE BOUNDARY LAYER C-----WHICH IS NOT A "PART" OF THE MODEL STD LEVELS AND A CALC AT THE C-----FIRST MODEL LAYER. THE VALUE FOR TENSIO AT THE BNDY LAYER IS SET C-----TO THE VALUE AT THE FIRST MODEL LAYER. IN NMC THE BNDY LAYER CAN C-----BE IGNORED ALL TOGETHER BECAUSE THE STRESS (TENSIO) IS ON SI'S, C-----INTERFACES WHILE THE DEACCERATION IS ON LAYERS SL'S. C C-----COMPUTE THE LOCAL FROUDE FOR THE STABLE CASE - MAKE SURE C-----THAT BY CHANCE THE PROJECTION OF THE LOCAL WIND (U1,V1) C-----SHOULD NOT BE SMALLER THEN 1.M/S, SINCE IT IS CUBED IN THE C-----DENOMINATOR C----- C DO 1195 I=1,IDIMT IF ( .NOT. ICRILV(I) ) THEN FRO2(I) = BNV2(I) / ( (AKWNMB * 0.5) * 1 ( RO(I,K) + RO(I,K+1) ) * 2 VELCO(I,K) * VELCO(I,K) * VELCO(I,K) ) * 3 TENSIO(I,K) ENDIF 1195 CONTINUE C ENDIF C C-----COMPUTE STRESS AT LEVEL IN QUESTION FOR STABLE CASE C DO 1210 I=1,IDIMT IF( .NOT.ICRILV(I) .AND. FRO2(I) .GT. CRIF2(I) ) THEN C C------FRO2 CHANGED TO > FROM .GE. C TENSIO(I,K+1) = TENSIO(I,K) * CRIF2(I) / FRO2(I) ENDIF C C----- CONSTANT STRESS IF CRIT FROUDE NOT MET (.LE. 6/1) C IF( .NOT. ICRILV(I) .AND. FRO2(I) .LE. CRIF2(I) ) THEN TENSIO(I,K+1) = TENSIO(I,K) ENDIF 1210 CONTINUE C C-----ALL DONE - PASS BACK STRESS PROFILE AND VERTICALLY DIFF C 1100 CONTINUE C RETURN END SUBROUTINE CMPIND C PARAMETER(MWAVE= 62 ,IROMB= 0 ) C PARAMETER(MWAVEP=MWAVE+1, 1 MDIM=(MWAVE+1)*(MWAVE+1)*2*IROMB+ 2 (MWAVE+1)*(MWAVE+2)*(1-IROMB)) C COMMON/COMIND/ INDXNN(MDIM),INDXMM(MDIM) C C INDXNN(MDIM) : 1-D INDEX OF CONVERTING INPUT FORM SPHER COEFF ARRAY C TO TRANSPOSED FORM ARRAY C INDXMM(MDIM) : 1-D INDEX OF CONVERTING TRANSPOSED FORM SPHER COEFF C ARRAY TO INPUT FORM SPHERICAL COEFF ARRAY C JROMB=IROMB IF(JROMB.EQ.0) THEN L=0 DO 10 M=1,MWAVEP NEND=MWAVEP-M+1 DO 10 NN=1,NEND N=NN+M-1 L=L+2 INDX=(MWAVEP*(N-M)-(N-M)*(N-M-1)/2+M)*2-1 INDXNN(L-1)=INDX INDXNN(L )=INDX+1 10 CONTINUE C L=0 DO 20 NN=1,MWAVEP LLN=MWAVEP-NN+1 DO 20 LL=1,LLN N=LL+NN-1 M=LL INDX=(M*MWAVEP-(MWAVEP-N)-(M-1)*M/2)*2-1 L=L+2 INDXMM(L-1)=INDX INDXMM(L )=INDX+1 20 CONTINUE RETURN ENDIF C IF(JROMB.EQ.1) THEN L=0 DO 30 M=1,MWAVEP DO 30 NN=1,MWAVEP N=NN+M-1 INDX=((N-M)*MWAVEP+M)*2-1 L=L+2 INDXNN(L-1)=INDX INDXNN(L )=INDX+1 30 CONTINUE C L=0 DO 40 NN=1,MWAVEP DO 40 LL=1,MWAVEP N=LL+NN-1 M=LL INDX=(MWAVEP*(M-1)+N-M+1)*2-1 L=L+2 INDXMM(L-1)=INDX INDXMM(L )=INDX+1 40 CONTINUE RETURN ENDIF C END SUBROUTINE TRANSI(A,KMAX) C PARAMETER(MWAVE= 62 ,IROMB= 0 ) C PARAMETER(MWAVEP=MWAVE+1, 1 MDIM=(MWAVE+1)*(MWAVE+1)*2*IROMB+ 2 (MWAVE+1)*(MWAVE+2)*(1-IROMB)) C COMMON/COMIND/ INDXNN(MDIM),INDXMM(MDIM) C DIMENSION A(MDIM,KMAX) DIMENSION B(MDIM) C DO 1 K=1,KMAX DO 2 M=1,MDIM B(INDXNN(M))=A(M,K) 2 CONTINUE DO 3 M=1,MDIM A(M,K)=B(M) 3 CONTINUE 1 CONTINUE C RETURN END SUBROUTINE TRANSO(A,KMAX) C PARAMETER(MWAVE= 62 ,IROMB= 0 ) C PARAMETER(MWAVEP=MWAVE+1, 1 MDIM=(MWAVE+1)*(MWAVE+1)*2*IROMB+ 2 (MWAVE+1)*(MWAVE+2)*(1-IROMB)) C COMMON/COMIND/ INDXNN(MDIM),INDXMM(MDIM) C DIMENSION A(MDIM,KMAX) DIMENSION B(MDIM) C DO 10 K=1,KMAX DO 11 M=1,MDIM B(INDXMM(M))=A(M,K) 11 CONTINUE DO 12 M=1,MDIM A(M,K)=B(M) 12 CONTINUE 10 CONTINUE C RETURN END SUBROUTINE DIABH(N1,ND,NSTEP,INI,NANL) PRINT 200 200 FORMAT ( ' HELLO FROM STUB DIABH ............... ') RETURN END SUBROUTINE DOINI(NANL,NANLH,IFGES,NGEST,NGESH,NGESTH,MODS,NITER, 1 NF,INI) PRINT 200 200 FORMAT ( ' HELLO FROM STUB DOINI ............... ') RETURN END SUBROUTINE GEST(N1,NG,NANL) PRINT 200 200 FORMAT ( ' HELLO FROM STUB GEST ................ ') RETURN END SUBROUTINE INSUR2(NFLIN,ALVSF,ALNSF,ALVWF,ALNWF, 1 FACSF,FACWF,PAERF) CFPP$ NOCONCUR R C************************************************************** C THE CODE READS IN SURFACE ALBEDO AND AEROSOL DATA. THE ALBEDO C DATA ARE DERIVED FROM MATTHEWS' VEGETATION INDEX BY USING A C MODIFIED BRIEGLEB'S SCHEME. THE AEROSOL DISTRIBUTION DATA IS C BASED ON MATTHEWS VEGETATION INDEX. --- Y.HOU MAR 7, 1995 C************************************************************** PARAMETER (IX= 384 , IY= 47 ) D I M E N S I O N 1 ALVSF( 384 , 47 ,4),ALNSF( 384 , 47 ,4) 2, ALVWF( 384 , 47 ,4),ALNWF( 384 , 47 ,4) 3, FACSF( 384 , 47 ), FACWF( 384 , 47 ) 4, PAERF( 384 , 47 ,5) C REWIND NFLIN DO K=1,4 READ(NFLIN) ((ALVSF(I,J,K),I=1,IX),J=1,IY) CALL ROW1NS (ALVSF(1,1,K)) ENDDO DO K=1,4 READ(NFLIN) ((ALVWF(I,J,K),I=1,IX),J=1,IY) CALL ROW1NS (ALVWF(1,1,K)) ENDDO DO K=1,4 READ(NFLIN) ((ALNSF(I,J,K),I=1,IX),J=1,IY) CALL ROW1NS (ALNSF(1,1,K)) ENDDO DO K=1,4 READ(NFLIN) ((ALNWF(I,J,K),I=1,IX),J=1,IY) CALL ROW1NS (ALNWF(1,1,K)) ENDDO READ(NFLIN) FACSF CALL ROW1NS(FACSF) READ(NFLIN) FACWF CALL ROW1NS(FACWF) DO 10 K=1,5 READ(NFLIN) ((PAERF(I,J,K),I=1,IX),J=1,IY) CALL ROW1NS(PAERF(1,1,K)) 10 CONTINUE C RETURN END CFPP$ NOCONCUR R SUBROUTINE KENPUT(LAT,RCL, & SLMSK,PSEXP,TG3,SHELEG,RADSL,DLWSF1, & TSEA,QSS,PLANTR,GFLX,ZORL,CD,CDQ, & RNET,HFLX,STSOIL, & CANOPY,DRAIN,SMSOIL,RUNOF,CLD1D, & U10,V10,T2,Q2, & HPBL,GAMT,GAMQ, & DQSFC1,DTSFC1,DUSFC1,DVSFC1, & DUSFCG,DVSFCG, & RAINC,RAINL, & U,V,T,Q,HSW,HLW,VVEL, & SNOWMT,SNOWEV,SNOWFL) PARAMETER(NVRKEN= 80 + 8 * 28 ,NPTKEN= 30 ) PARAMETER(NSTKEN= 48 ) COMMON/COMGPD/ SVDATA(NVRKEN,NPTKEN,NSTKEN), 1 IGRD(NPTKEN),JGRD(NPTKEN), 2 IGRDR(NPTKEN),JGRDR(NPTKEN), 3 ITNUM,NPOINT,ISAVE,ISSHRT,ILSHRT,IKFREQ PARAMETER(IM= 384 ,IX= 386 ,KM= 28 ) REAL SLMSK(IM),PSEXP(IM),TG3(IM),SHELEG(IM),RADSL(IM),DLWSF1(IM), & TSEA(IM),QSS(IM),PLANTR(IM),GFLX(IM),ZORL(IM),CD(IM),CDQ(IM), & RNET(IM),HFLX(IM),STSOIL(IM,2), & CANOPY(IM),DRAIN(IM),SMSOIL(IM,2),RUNOF(IM),CLD1D(IM), & U10(IM),V10(IM),T2(IM),Q2(IM), & HPBL(IM),GAMT(IM),GAMQ(IM), & DQSFC1(IM),DTSFC1(IM),DUSFC1(IM),DVSFC1(IM), & DUSFCG(IM),DVSFCG(IM), & RAINC(IM),RAINL(IM), & U(IX,KM),V(IX,KM),T(IX,KM),Q(IX,KM), & HSW(IM,KM),HLW(IM,KM),VVEL(IM,KM), & SNOWMT(IM),SNOWEV(IM),SNOWFL(IM) PARAMETER(CNWATT=- 4.1855E+0 *1.E4/60.) DO 330 IGPT=1,NPOINT IF(LAT.EQ.JGRD(IGPT)) THEN SVDATA(11,IGPT,ITNUM)=SVDATA(11,IGPT,ITNUM)+RAINC(IGRD(IGPT)) SVDATA(12,IGPT,ITNUM)=SVDATA(12,IGPT,ITNUM)+RAINL(IGRD(IGPT)) IF(ISAVE.NE.0) THEN SVDATA( 1,IGPT,ITNUM)= IGRD(IGPT) SVDATA( 2,IGPT,ITNUM)= JGRD(IGPT) SVDATA( 3,IGPT,ITNUM)= SLMSK (IGRD(IGPT)) SVDATA( 4,IGPT,ITNUM)= PSEXP (IGRD(IGPT)) *10. SVDATA( 8,IGPT,ITNUM)= TG3 (IGRD(IGPT)) SVDATA( 10,IGPT,ITNUM)= SHELEG(IGRD(IGPT)) SVDATA( 13,IGPT,ITNUM)= RADSL(IGRD(IGPT))*CNWATT SVDATA( 14,IGPT,ITNUM)= DLWSF1(IGRD(IGPT)) SVDATA( 5,IGPT,ITNUM)= TSEA (IGRD(IGPT)) SVDATA( 15,IGPT,ITNUM)= QSS (IGRD(IGPT)) SVDATA( 16,IGPT,ITNUM)= PLANTR(IGRD(IGPT)) SVDATA( 19,IGPT,ITNUM)= GFLX(IGRD(IGPT)) SVDATA( 22,IGPT,ITNUM)= ZORL (IGRD(IGPT)) SVDATA( 23,IGPT,ITNUM)= CD (IGRD(IGPT)) SVDATA( 24,IGPT,ITNUM)= CDQ (IGRD(IGPT)) SVDATA( 62,IGPT,ITNUM)= RNET (IGRD(IGPT)) CCKEN SVDATA( 63,IGPT,ITNUM)= EVAP (IGRD(IGPT)) SVDATA( 64,IGPT,ITNUM)= HFLX (IGRD(IGPT)) SVDATA( 6,IGPT,ITNUM)= STSOIL (IGRD(IGPT),1) SVDATA( 7,IGPT,ITNUM)= STSOIL (IGRD(IGPT),2) SVDATA( 34,IGPT,ITNUM)= U10 (IGRD(IGPT)) SVDATA( 35,IGPT,ITNUM)= V10 (IGRD(IGPT)) SVDATA( 30,IGPT,ITNUM)= T2 (IGRD(IGPT)) SVDATA( 31,IGPT,ITNUM)= Q2 (IGRD(IGPT)) SVDATA( 32,IGPT,ITNUM)= CANOPY(IGRD(IGPT)) SVDATA( 33,IGPT,ITNUM)= DRAIN(IGRD(IGPT)) SVDATA( 17,IGPT,ITNUM)= DQSFC1(IGRD(IGPT)) SVDATA( 18,IGPT,ITNUM)= DTSFC1(IGRD(IGPT)) SVDATA( 20,IGPT,ITNUM)= DUSFC1(IGRD(IGPT)) SVDATA( 21,IGPT,ITNUM)= DVSFC1(IGRD(IGPT)) SVDATA( 28,IGPT,ITNUM)= DUSFCG(IGRD(IGPT)) SVDATA( 29,IGPT,ITNUM)= DVSFCG(IGRD(IGPT)) SVDATA( 9,IGPT,ITNUM)= SMSOIL (IGRD(IGPT),1) SVDATA( 61,IGPT,ITNUM)= SMSOIL (IGRD(IGPT),2) CCKEN SVDATA( 65,IGPT,ITNUM)= RUNOF (IGRD(IGPT)) SVDATA( 63,IGPT,ITNUM)= HPBL(IGRD(IGPT)) SVDATA( 64,IGPT,ITNUM)= GAMT(IGRD(IGPT)) SVDATA( 65,IGPT,ITNUM)= GAMQ(IGRD(IGPT)) SVDATA( 66,IGPT,ITNUM)= CLD1D (IGRD(IGPT)) SVDATA( 67,IGPT,ITNUM)= SNOWEV(IGRD(IGPT)) SVDATA( 68,IGPT,ITNUM)= SNOWMT(IGRD(IGPT)) SVDATA( 69,IGPT,ITNUM)= SNOWFL(IGRD(IGPT)) IF(ILSHRT.LT.2) THEN R=SQRT(RCL) DO 331 K=1, 28 SVDATA(K+ 80 +0* 28 ,IGPT,ITNUM)=U(IGRD(IGPT),K)*R SVDATA(K+ 80 +1* 28 ,IGPT,ITNUM)=V(IGRD(IGPT),K)*R SVDATA(K+ 80 +2* 28 ,IGPT,ITNUM)=T(IGRD(IGPT),K) SVDATA(K+ 80 +3* 28 ,IGPT,ITNUM)=Q(IGRD(IGPT),K) IF(ILSHRT.LT.1) THEN SVDATA(K+ 80 +4* 28 ,IGPT,ITNUM)=HSW(IGRD(IGPT),K) SVDATA(K+ 80 +5* 28 ,IGPT,ITNUM)=HLW(IGRD(IGPT),K) C VVEL SAVED IN PLACE OF DIV; VOR NO LONGER SAVED EITHER SVDATA(K+ 80 +6* 28 ,IGPT,ITNUM)=VVEL(IGRD(IGPT),K) ENDIF 331 CONTINUE ENDIF ENDIF ENDIF 330 CONTINUE RETURN END CFPP$ NOCONCUR R CFPP$ EXPAND(FPVS) C----------------------------------------------------------------------- SUBROUTINE LRGSCL(IMX2,IMX22,KMX,DT,PS,T,Q,SL,DEL,SLK,RN,LAT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: LRGSCL CALCULATE GRID-SCALE PRECIPITATION C PRGMMR: HUA-LU PAN ORG: W/NMC23 DATE: 94-04-15 C C ABSTRACT: CALCULATES GRID-SCALE CONDENSATION FOR ONE LEAP-FROG C TIMESTEP, PRODUCES RAIN, AND ADJUSTS TEMPERATURE AND SPECIFIC C HUMIDITY BY WET-BULB PROCESS. EVAPORATION OF PART OR ALL OF THE C RAIN MAY OCCUR AS IT TRAVERSES UNSATURATED LAYERS ON THE WAY DOWN. C FOR CONDITIONALLY UNSTABLE LAYERS, A CONVECTIVE ADJUSTMENT PROCEDURE C IS APPLIED TO ADJUST TO A UNIFORM THETA-E. C C PROGRAM HISTORY LOG: C 94-04-15 HUA-LU PAN C C USAGE: CALL LRGSCL(IM,IM2,KM,DT,PS,T,Q,SL,DEL,SLK,RAIN,LAT) C C INPUT ARGUMENT LIST: C IM - INTEGER NUMBER OF POINTS C IM2 - REAL FIRST DIMENSION OF T AND Q C KM - INTEGER NUMBER OF LEVELS C DT - REAL TIME STEP IN SECONDS C PS - REAL (IM) SURFACE PRESSURE IN KILOPASCALS (CB) C T - REAL (IM2,KM) CURRENT TEMPERATURE IN KELVIN C Q - REAL (IM2,KM) CURRENT SPECIFIC HUMIDITY IN KG/KG C SL - REAL (KM) SIGMA VALUES C DEL - REAL (KM) SIGMA LAYER THICKNESS C SLK - REAL (KM) SIGMA VALUES ** KAPPA C LAT - INTEGER LATITUDE NUMBER C C OUTPUT ARGUMENT LIST: C Q - REAL (IM2,KM) ADJUSTED SPECIFIC HUMIDITY IN KG/KG C T - REAL (IM2,KM) ADJUSTED TEMPERATURE IN KELVIN C RN - REAL (IM) LARGE-SCALE RAIN IN METERS C C SUBPROGRAMS CALLED: C FPVS - FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE C FPKAP - FUNCTION TO COMPUTE P RAISED TO THE FACTOR KAPPA C FTHE - FUNCTION TO COMPUTE THETA-E C FTMA - FUNCTION TO COMPUTE TEMPERATURE AND MOISTURE ALONG A C MOIST ADIABAT C C REMARKS: THE PRECIPITATION REACHING THE GROUND SHOULD BE HALVED C BEFORE IT IS USED TO INCREMENT GESHEM, THE RUNNING TOTAL. THIS C PREVENTS DOUBLE-COUNTING OF GESHEM, WHICH IS INCREMENTED EVERY C HALF LEAP-FROG TIMESTEP. C THE EVAPORATION RATE FOR FALLING PRECIP IS CALCULATED C ACCORDING TO A METHOD DEVISED BY E.KESSLER, IN WHICH A MEAN DROP C SURFACE AREA IS OBTAINED FROM THE RAINWATER CONTENT. C ICE IS NOT CONSIDERED. C FUNCTIONS FPVS,FPKAP,FTHE,FTMA ARE INLINED BY FPP. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: CRAY C C$$$ DIMENSION DEL(KMX),SL(KMX),PS(IMX2), & Q(IMX22,KMX),T(IMX22,KMX),RN(IMX2) C PHYSICAL PARAMETERS PARAMETER(G= 9.8000E+0 ,RD= 2.8705E+2 ,RV= 4.6150E+2 , & CP= 1.0046E+3 ,HVAP= 2.5000E+6 ) PARAMETER(ELOCP=HVAP/CP,EL2ORC=HVAP*HVAP/(RV*CP), & EPS=RD/RV,EPSM1=RD/RV-1.) C----------------------------------------------------------------------- C CONDENSE RAIN TO WETBULB TEMPERATURE IF SUPERSATURATED C OR EVAPORATE RAIN USING KESSLER PARAMETERIZATION. DO I=1,IMX2 RN(I)=0. ENDDO DO K=KMX,1,-1 DO I=1,IMX2 DPOVG=DEL(K)/G*PS(I) ES=FPVS(T(I,K)) QS=EPS*ES/(SL(K)*PS(I)+EPSM1*ES) QCOND=(Q(I,K)-QS)/(1.+EL2ORC*QS/T(I,K)**2) IF(QCOND.GT.0.) THEN Q(I,K)=Q(I,K)-QCOND T(I,K)=T(I,K)+QCOND*ELOCP RN(I)=RN(I)+QCOND*DPOVG ELSEIF(RN(I).GT.0.) THEN QEVAP=-QCOND*(1.-EXP(-0.32*SQRT(2.*DT*RN(I)))) RNEVAP=MIN(QEVAP*DPOVG,RN(I)) Q(I,K)=Q(I,K)+RNEVAP/DPOVG T(I,K)=T(I,K)-RNEVAP/DPOVG*ELOCP RN(I)=RN(I)-RNEVAP ENDIF ENDDO ENDDO C----------------------------------------------------------------------- RETURN END CFPP$ NOCONCUR R SUBROUTINE PLN2I(QLNT,QLNV,COLRAD,LAT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PLN2T EVALUATES ASSOCIATED LEGENDRE FUNCTIONS. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-10-25 C C ABSTRACT: EVALUATES THE REQUIRED VALUES OF THE NORMALIZED C ASSOCIATED LEGENDRE FUNCTION AT A PRESCRIBED COLATITUDE. C A STANDARD RECURSION RELATION IS USED WITH REAL ARITHMETIC. C C PROGRAM HISTORY LOG: C 88-10-25 JOSEPH SELA C C USAGE: CALL PLN2T (QLNT, QLNV, COLRAD, LAT) C INPUT ARGUMENT LIST: C COLRAD - HALF PRECISION COLATITUDES IN RADIANS FOR WHICH C THE ASSOCIATED LEGENDRE FUNCTIONS ARE TO BE C COMPUTED. C LAT - INDEX WHICH INDICATES THE CURRENT LATITUDE. C C OUTPUT ARGUMENT LIST: C QLNT - DOUBLED SCALAR TRIANGLE OF C HALF PRECISION ASSOCIATED LEGENDRE FUNCTIONS. C QLNV - DOUBLED VECTOR TRIANGLE OF C HALF PRECISION ASSOCIATED LEGENDRE FUNCTIONS. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ CC DIMENSION QLNT( 4032 ) DIMENSION QLNV( 4158 ) DIMENSION COLRAD( 47 ) CC DIMENSION X( 63 ) DIMENSION DPLN( 4158 ) CC COMMON /PLN2TI/ DEPS( 4158 ),RDEPS( 4158 ), 1 DX( 126 ),Y( 63 ),INDXMV( 4158 ) CC CCC DATA IFIR /0/ CCC PART BETWEEN GUARDS MADE INTO SR GPLN2I. CCC 7 DEC 1990 M. ROZWODOSKI CC COLR = COLRAD(LAT) SINLAT = COS(COLR) COS2 = 1.0 - SINLAT * SINLAT PROD = 1.0 DO 600 LL=1, 63 X(LL) = 0.5*PROD CCCC IF (PROD .LT. 1.0E-75) PROD=0.0 PROD = PROD*COS2*Y(LL) 600 CONTINUE DO 620 LL=1, 63 X(LL) = SQRT(X(LL)) 620 CONTINUE DO 640 LL=1, 63 DPLN(2*LL-1) = X(LL) DPLN(2*LL ) = X(LL) 640 CONTINUE LPLUS = 126 DO 700 LL=1, 126 DPLN(LL+LPLUS) = DX(LL) * SINLAT * DPLN(LL) 700 CONTINUE LP2 = 0 LP1 = 126 LP0 = 2 * 126 LEN = 126 - 2 DO 740 N=3, 64 CDIR$ IVDEP DO 720 LL=1,LEN DPLN(LL+LP0) = (SINLAT * DPLN(LL+LP1) 1 - DEPS(LL+LP1) * DPLN(LL+LP2)) * RDEPS(LL+LP0) 720 CONTINUE LP2 = LP1 LP1 = LP0 LP0 = LP0 + LEN LEN = LEN - 2 740 CONTINUE CC CC TRANSPOSE VECTOR DPLN ARRAY FROM CRAY ORDER TO IBM ORDER. DO 800 I=1, 4158 QLNV(INDXMV(I)) = DPLN(I) 800 CONTINUE CC LPV = 0 LPT = 0 LEN = 126 DO 860 N=1, 63 DO 840 LL=1,LEN QLNT(LL+LPT) = QLNV(LL+LPV) 840 CONTINUE LPV = LPV + LEN + 2 LPT = LPT + LEN LEN = LEN - 2 860 CONTINUE CC RETURN END SUBROUTINE GPLN2I C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GPLN2T SETS COMMON FOR SUBROUTINE PLN2T. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 91-03-14 C C ABSTRACT: INITIALIZES THE CONSTANT VARIABLES AND ARRAYS C OF A COMMON FOR SUBROUTINE PLN2T. C C PROGRAM HISTORY LOG: C 91-03-14 JOSEPH SELA C C USAGE: CALL GPLN2T C C REMARKS: CALL SUBROUTINE ONCE BEFORE CALLS TO PLN2T. C REFER TO PLN2T FOR ADDITIONAL DOCUMENTATION. C C ATTRIBUTES: C LANGUAGE: FORTRAN, CFT77. C MACHINE: CRAY Y-MP. C C$$$ CC DIMENSION X( 63 ) CC COMMON /PLN2TI/ DEPS( 4158 ),RDEPS( 4158 ), 1 DX( 126 ),Y( 63 ),INDXMV( 4158 ) CC CCC DATA IFIR /0/ CC CCC IF (IFIR .EQ. 1) GO TO 500 CCC IFIR = 1 DO 200 LL=1, 63 RDEPS(LL) = 0.0 200 CONTINUE LPLUS = 63 LEN = 63 DO 240 INDE=2, 64 DO 220 LL=1,LEN L = LL - 1 N = L + INDE - 1 RDEPS(LL+LPLUS) = (N*N - L*L) / (4.0 * N*N - 1.0) 220 CONTINUE LPLUS = LPLUS + LEN LEN = LEN - 1 240 CONTINUE DO 260 I= 64 , 2079 RDEPS(I) = SQRT(RDEPS(I)) 260 CONTINUE DO 300 I=1, 2079 DEPS(2*I-1) = RDEPS(I) DEPS(2*I ) = RDEPS(I) 300 CONTINUE IBEGIN = 126 + 1 DO 320 I=IBEGIN, 4158 RDEPS(I) = 1.0/DEPS(I) 320 CONTINUE DO 400 LL=1, 63 X(LL) = LL*2+1 400 CONTINUE DO 420 LL=1, 63 Y(LL) = X(LL)/(X(LL)-1.) 420 CONTINUE DO 440 LL=1, 63 X(LL) = SQRT(X(LL)) 440 CONTINUE DO 460 LL=1, 63 DX(2*LL-1) = X(LL) DX(2*LL ) = X(LL) 460 CONTINUE C 500 CONTINUE CC CC SET INDEX ARRAY FOR TRANSPOSING VECTOR ARRAY CC FROM CRAY ORDER TO IBM ORDER. L=0 DO 640 NN=1, 64 LLN=MIN0( 64 -NN+1, 63 ) DO 620 LL=1,LLN INDX=(( 62 +3)*(LL-1)-(LL-1)*LL/2+NN)*2 L=L+2 INDXMV(L-1)=INDX-1 INDXMV(L )=INDX 620 CONTINUE 640 CONTINUE CC RETURN END SUBROUTINE EPSLON(EPS,JCAP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: EPSLON COMPUTES EPS, A FUNCTION OF WAVE NUMBER. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-01 C C ABSTRACT: COMPUTES EPS, A FUNCTION OF WAVE NUMBER. C EPS IS USED IN CALCULATING LEGENDRE POLYS. AND THEIR DERIVATIVES. C EPS IS ALSO USED IN COMPUTING WINDS FROM DIVERGENCE AND VORTICITY. C C PROGRAM HISTORY LOG: C 88-04-01 JOSEPH SELA C C USAGE: CALL EPSLON (EPS, JCAP) C INPUT ARGUMENT LIST: C JCAP - INDEX INDICATING THE SPECTRAL TRUNCATION USED. C C OUTPUT ARGUMENT LIST: C EPS - ARRAY COMPUTED FROM SQRT((N**2-L**2)/(4*N**2-1)). C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ DIMENSION EPS( 63 , 64 ) JCAP1 = JCAP + 1 JCAP2 = JCAP + 2 DO 1 LL=1,JCAP1 L = LL - 1 DO 1 INDE=2,JCAP2 N = L + INDE - 1 A = (N*N - L*L) / (4.0 * N*N - 1.0) EPS(LL,INDE)= SQRT (A) 1 CONTINUE DO 2 LL=1, 63 EPS(LL,1) = 0.0 E 0 2 CONTINUE RETURN END SUBROUTINE EPSILO(EPS,JCAP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: EPSLON COMPUTES EPS, A FUNCTION OF WAVE NUMBER. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-01 C C ABSTRACT: COMPUTES EPS, A FUNCTION OF WAVE NUMBER. C EPS IS USED IN CALCULATING LEGENDRE POLYS. AND THEIR DERIVATIVES. C EPS IS ALSO USED IN COMPUTING WINDS FROM DIVERGENCE AND VORTICITY. C C PROGRAM HISTORY LOG: C 88-04-01 JOSEPH SELA C C USAGE: CALL EPSLON (EPS, JCAP) C INPUT ARGUMENT LIST: C JCAP - INDEX INDICATING THE SPECTRAL TRUNCATION USED. C C OUTPUT ARGUMENT LIST: C EPS - ARRAY COMPUTED FROM SQRT((N**2-L**2)/(4*N**2-1)). C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ DIMENSION EPS( 64 , 63 ) JCAP1 = JCAP + 1 JCAP2 = JCAP + 2 DO 1 LL=1,JCAP1 L = LL - 1 DO 1 INDE=2,JCAP2 N = L + INDE - 1 A = (N*N - L*L) / (4.0 * N*N - 1.0) EPS(INDE,LL)= SQRT (A) 1 CONTINUE DO 2 LL=1, 63 EPS(1,LL) = 0.0 E 0 2 CONTINUE RETURN END CFPP$ NOCONCUR R SUBROUTINE DERIVS(SYN,DYN,RCS2) C................................................................. C SYN(1, 0* 28 +0* 28 +1) ZE C SYN(1, 1* 28 +0* 28 +1) DI C SYN(1, 2* 28 +0* 28 +1) TE C SYN(1, 3* 28 +0* 28 +1) RQ C SYN(1, 3* 28 +1* 28 +1) DPDLAM C SYN(1, 3* 28 +1* 28 +2) DPDPHI C SYN(1, 3* 28 +1* 28 +3) ULN C SYN(1, 4* 28 +1* 28 +3) VLN C................................................................. C DYN(1, 0* 28 +0* 28 +1) D(T)/D(PHI) C DYN(1, 1* 28 +0* 28 +1) D(RQ)/D(PHI) C DYN(1, 1* 28 +1* 28 +1) D(T)/D(LAM) C DYN(1, 2* 28 +1* 28 +1) D(RQ)/D(LAM) C DYN(1, 2* 28 +2* 28 +1) D(U)/D(LAM) C DYN(1, 3* 28 +2* 28 +1) D(V)/D(LAM) C DYN(1, 4* 28 +2* 28 +1) D(U)/D(PHI) C DYN(1, 5* 28 +2* 28 +1) D(V)/D(PHI) C................................................................. PARAMETER(LOTS =5* 28 +1* 28 +2,LOTST=2* 28 +1, & KSZ =0* 28 +0* 28 +1, & KSD =1* 28 +0* 28 +1, & KST =2* 28 +0* 28 +1, & KSR =3* 28 +0* 28 +1, & KSPLAM =3* 28 +1* 28 +1, & KSPPHI =3* 28 +1* 28 +2,KSTB=3* 28 +1* 28 +2, & KSU =3* 28 +1* 28 +3, & KSV =4* 28 +1* 28 +3) PARAMETER(LOTD =6* 28 +2* 28 , & KDTPHI =0* 28 +0* 28 +1, & KDRPHI =1* 28 +0* 28 +1, & KDTLAM =1* 28 +1* 28 +1, & KDRLAM =2* 28 +1* 28 +1, & KDULAM =2* 28 +2* 28 +1, & KDVLAM =3* 28 +2* 28 +1, & KDUPHI =4* 28 +2* 28 +1, & KDVPHI =5* 28 +2* 28 +1) C... DIMENSION RL( 63 ),RLCS2( 63 ), 1 SYN( 386 ,LOTS),DYN( 386 ,LOTD) C................................................................. DO LL=1, 63 RL(LL)=FLOAT(LL-1)/ 6.3712E+6 ENDDO C DO I=1, 63 RLCS2(I)=RL(I)*RCS2 ENDDO C C CALCULATE T RQ U V ZONAL DERIVS. BY MULTIPLICATION WITH I*L C NOTE RLCS2=RCS2*L/ 6.3712E+6 C DO K=1, 28 DO I=1, 63 C D(T)/D(LAM) DYN(2*I-1,KDTLAM-1+K)= -SYN(2*I ,KST-1+K)*RLCS2(I) DYN(2*I ,KDTLAM-1+K)= SYN(2*I-1,KST-1+K)*RLCS2(I) DYN( 192 +2*I-1,KDTLAM-1+K)= -SYN( 192 +2*I ,KST-1+K)*RLCS2(I) DYN( 192 +2*I ,KDTLAM-1+K)= SYN( 192 +2*I-1,KST-1+K)*RLCS2(I) C D(U)/D(LAM) DYN(2*I-1,KDULAM-1+K)= -SYN(2*I ,KSU-1+K)*RLCS2(I) DYN(2*I ,KDULAM-1+K)= SYN(2*I-1,KSU-1+K)*RLCS2(I) DYN( 192 +2*I-1,KDULAM-1+K)= -SYN( 192 +2*I ,KSU-1+K)*RLCS2(I) DYN( 192 +2*I ,KDULAM-1+K)= SYN( 192 +2*I-1,KSU-1+K)*RLCS2(I) C D(V)/D(LAM) DYN(2*I-1,KDVLAM-1+K)= -SYN(2*I ,KSV-1+K)*RLCS2(I) DYN(2*I ,KDVLAM-1+K)= SYN(2*I-1,KSV-1+K)*RLCS2(I) DYN( 192 +2*I-1,KDVLAM-1+K)= -SYN( 192 +2*I ,KSV-1+K)*RLCS2(I) DYN( 192 +2*I ,KDVLAM-1+K)= SYN( 192 +2*I-1,KSV-1+K)*RLCS2(I) ENDDO ENDDO C DO K=1, 28 DO I=1, 63 C D(RQ)/D(LAM) DYN(2*I-1,KDRLAM-1+K)= -SYN(2*I ,KSR-1+K)*RLCS2(I) DYN(2*I ,KDRLAM-1+K)= SYN(2*I-1,KSR-1+K)*RLCS2(I) DYN( 192 +2*I-1,KDRLAM-1+K)= -SYN( 192 +2*I ,KSR-1+K)*RLCS2(I) DYN( 192 +2*I ,KDRLAM-1+K)= SYN( 192 +2*I-1,KSR-1+K)*RLCS2(I) ENDDO ENDDO C CALL FTI_LONF(SYN,DUMMY,(5* 28 + 28 +2)*2,1) C C D(T)/D(PHI) D(RQ)/D(PHI) IN S. HEMI. DO K=1, 28 DO I=1, 192 DYN(I+ 192 ,KDTPHI-1+K)=-DYN(I+ 192 ,KDTPHI-1+K) ENDDO ENDDO DO K=1, 28 DO I=1, 192 DYN(I+ 192 ,KDRPHI-1+K)=-DYN(I+ 192 ,KDRPHI-1+K) ENDDO ENDDO C SYNTHESIZE TEMP. MERIDIONAL AND ZONAL DERIVATIVES C SYNTHESIZE MOISTURE MERIDIONAL AND ZONAL DERIVATIVES C SYNTHESIZE U AND V ZONAL DERIVATIVES C CALL FTI_LONF(DYN,DUMMY,(4* 28 +2* 28 )*2,1) C C CALCULATE GRID MERIDIONAL DERIVATIVES OF U AND V. C C COS*D(U)/D(THETA)= D(V)/D(LAM)-A*ZETA*COS**2 C COS*D(V)/D(THETA)=-D(U)/D(LAM)+A*DIVR*COS**2 C DO K=1, 28 DO J=1, 384 DYN(J,KDUPHI-1+K)= DYN(J,KDVLAM-1+K)-SYN(J,KSZ-1+K) DYN(J,KDVPHI-1+K)=-DYN(J,KDULAM-1+K)+SYN(J,KSD-1+K) ENDDO ENDDO C RETURN END SUBROUTINE LONLAT(XLON,LON2,XLAT,COLRAD,LAT2) PARAMETER (TPI=2. E 0* 3.141593E+0 ,HPI=0.5 E 0* 3.141593E+0 ) DIMENSION XLON(LON2,LAT2),XLAT(LON2,LAT2),COLRAD(LAT2) C.... GET LON,LAT IN RADIANS C.... GET LONGITUDINAL INCREMENT LON = LON2 / 2 BPHI = TPI / LON DO 5 J=1,LAT2 DO 5 I=1,LON XLON(I,J) = (I-1) * BPHI XLAT(I,J) = HPI - COLRAD(J) XLON(I+LON,J) = XLON(I,J) XLAT(I+LON,J) = -XLAT(I,J) 5 CONTINUE RETURN END SUBROUTINE BILWGT(COLIN,LATIN2,LONIN2,COLOUT,LATUT2,LONUT2, 1 INSLAT,WGTLAT,ILEFT,IRGHT,WGTLON) PARAMETER (HALFPI=0.5 E 0* 3.141593E+0 ) DIMENSION COLIN(LATIN2) DIMENSION COLOUT(LATUT2),INSLAT(LATUT2),WGTLAT(LATUT2) DIMENSION ILEFT(LONUT2),IRGHT(LONUT2),WGTLON(LONUT2) C===> PREPARE THREE SFC FIELDS AS INPUT TO RADIATION CALCULATIONS C ALSO PREPARE 3 CONVECTIVE ARRAYS FOR INPUT TO CLD SCHEME.. JB = 1 DO 19 LAT=1,LATUT2 CCC PRINT 100,LAT,XLAT C===> IF OUTPUT LAT IS POLEWARD OF INPUT LAT=1 ,THEN EXTRAPOLATE.. IF (COLOUT(LAT).LE.COLIN(1)) GO TO 16 C---- GET UPPER LEFT POINT ON BASE GRDBOX SURROUNDING THE GAUSIAN C POINT -- NEEDED FOR THE INTERPOLATION JST = JB + 1 DO 11 JAK=JST,LATIN2 JB = JAK - 1 IF(COLOUT(LAT).LE.COLIN(JAK)) GO TO 14 11 CONTINUE INSLAT(LAT) = LATIN2 WGTLAT(LAT) = 0.5 E 0 * (COLIN(LATIN2) - COLOUT(LAT)) / 1 (COLIN(LATIN2) - HALFPI) GO TO 19 14 INSLAT(LAT) = JB C---- NORMALIZED DISTANCE FROM POLEWARD LAT TO GAUSSIAN LAT WGTLAT(LAT) = (COLIN(JB) - COLOUT(LAT)) / 1 (COLIN(JB) - COLIN(JB+1)) GO TO 19 16 INSLAT(LAT) = -1 WGTLAT(LAT) = (COLOUT(LAT) - COLIN(1)) / 1 (COLIN(1) - COLIN(2)) 19 CONTINUE C---- GET LEFT POINT ON BASE GRDBOX LONIN = LONIN2 / 2 LONOUT = LONUT2 / 2 RATLON = FLOAT(LONIN) / FLOAT(LONOUT) C RATLON = (360. E 0 / LONOUT) / (360. E 0 / LONIN) DO 21 I=1,LONOUT WGTLON(I) = FLOAT(I-1) * RATLON + 1. E 0 ILEFT(I) = WGTLON(I) IRGHT(I) = ILEFT(I) + 1 IF (IRGHT(I).GT.LONIN) IRGHT(I) = 1 WGTLON(I) = WGTLON(I) - ILEFT(I) ILEFT(I+LONOUT) = ILEFT(I) + LONIN IRGHT(I+LONOUT) = IRGHT(I) + LONIN WGTLON(I+LONOUT) = WGTLON(I) 21 CONTINUE RETURN END SUBROUTINE INSURF(ALBEDO,SLMSK, 1 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,ALBEDR,SLMSKR) DIMENSION ALBEDO( 384 , 47 ),SLMSK( 384 , 47 ) DIMENSION ILEFTR( 384 ),IRGHTR( 384 ),WGRLON( 384 ) DIMENSION INRLAT( 47 ),WGRLAT( 47 ) DIMENSION ALBEDR( 384 , 47 ),SLMSKR( 384 , 47 ) DIMENSION FSLMSK( 384 , 47 ),FICMSK( 384 , 47 ), 1 WORK2( 384 ), 2 RSLMSK( 384 , 47 ),RICMSK( 384 , 47 ) C.... C.... INTEROLATE ALBEDO TO RADIATION GRID C.... CALL GGINTF(ALBEDO, 384 , 47 , 47 , 1 ALBEDR, 384 , 47 , 47 ,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK2,1,1,1) C.... C.... CREATE LAND(1)SEA(0) MASK ON MODEL GRID IN FSLMSK C.... CREATE ICE(1)NO-ICE(0) MASK ON MODEL GRID IN FICMSK C.... DO 110 J=1, 47 DO 110 I=1, 384 FSLMSK(I,J) = 1. E 0 FICMSK(I,J) = 0. E 0 110 CONTINUE DO 120 J=1, 47 DO 120 I=1, 384 IF(SLMSK(I,J).EQ.0.0 E 0.OR.SLMSK(I,J).EQ.2.0 E 0) 1 FSLMSK(I,J) = 0.0 E 0 IF(SLMSK(I,J).EQ.2.0 E 0) FICMSK(I,J) = 1.0 E 0 120 CONTINUE CALL GGINTF(FSLMSK, 384 , 47 , 47 , 1 RSLMSK, 384 , 47 , 47 ,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK2,1,1,1) CALL GGINTF(FICMSK, 384 , 47 , 47 , 1 RICMSK, 384 , 47 , 47 ,1, 2 ILEFTR,IRGHTR,WGRLON,INRLAT,WGRLAT,WORK2,1,1,1) C..... ADJUST INTERPOLATED TSEAR FOR PROPER LAND/SEA/SEAICE C DISTRIBUTION,WHICH HAS BEEN INTERPOLATED ABOVE..... C..... ALSO CREATE SEA(0),LAND(1),ICE(2) MASK FOR RAD GRID(SLMSKR) C.... C.... CREATE ICE(2) LAND(1)SEA(0) MASK ON RADIATION GRID IN SLMSKR C.... DO 130 J=1, 47 DO 130 I=1, 384 SLMSKR(I,J) = 1 IF (RSLMSK(I,J).LT.0.5 E 0) SLMSKR(I,J) = 0 IF (RSLMSK(I,J).LT.0.5 E 0.AND.RICMSK(I,J).GT.0.5 E 0) 1 SLMSKR(I,J) = 2 130 CONTINUE RETURN END SUBROUTINE GGINTF(XIN,IIN,JTWIDL,JIN,XOUT,IOUT,JPOUT,JOUT,LEVS, 1 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK, 2 LTWIDL,LATRD1,LATINB) C---- CODE BILINEARLY INTERPOLATES BETWEEN GAUSSIAN GRIDS--- C J = 1 IS JUST BELO N.POLE, I = 1 IS GREENWICH (THEN GO EAST). C===> IIN,JIN ARE I,J DIMENSIONS OF INPUT GRID C===> IOUT,JOUT ARE I,J DIMENSIONS OF OUTPUT GRID C===> JIN2,JOUT2=JIN/2,JOUT/2 DIMENSION XIN(IIN,LEVS,JTWIDL) DIMENSION XOUT(IOUT,LEVS,JPOUT) DIMENSION WORK(IIN,LEVS) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION INSLAT(JOUT),WGTLAT(JOUT) DO 95 LATOUT=1,JPOUT LAT=LATOUT+LATINB-1 CCC PRINT 100,LAT,XLAT C..... IF OUTPUT LAT IS POLEWARD OF INPUT LAT=1 ,THEN EXTRAPOLATE.. IF (INSLAT(LAT).LT.0) GO TO 70 C INTH = MOD(LTWIDL + INSLAT(LAT) - LATRD1 - 1,JTWIDL) + 1 INTH = MOD(LTWIDL + INSLAT(LAT) + JTWIDL - LATRD1 - 1,JTWIDL) + 1 IF(INTH.EQ.0) THEN PRINT *,'LAT,INTH,LTWIDL,INSLAT(LAT),LATRD1,JTWIDL' PRINT *,LAT,INTH,LTWIDL,INSLAT(LAT),LATRD1,JTWIDL CALL ABORT ENDIF IF (INSLAT(LAT).EQ.JIN) GO TO 20 INTH1 = MOD(INTH,JTWIDL) + 1 DO 10 K=1,LEVS DO 10 I=1,IIN WORK(I,K) = XIN(I,K,INTH1)*WGTLAT(LAT) + 1 XIN(I,K,INTH) * (1. E 0 - WGTLAT(LAT)) 10 CONTINUE GO TO 40 20 IINHF = IIN / 2 DO 30 K=1,LEVS DO 30 I=1,IINHF WORK(I,K) = XIN(I+IINHF,K,INTH) * WGTLAT(LAT)+ 1 XIN(I,K,INTH) * (1. E 0 - WGTLAT(LAT)) WORK(I+IINHF,K) = XIN(I,K,INTH) * WGTLAT(LAT) + 1 XIN(I+IINHF,K,INTH) * (1. E 0 - WGTLAT(LAT)) 30 CONTINUE 40 DO 50 K=1,LEVS DO 50 I=1,IOUT XOUT(I,K,LATOUT) = (1. E 0 - WGTLON(I)) * WORK(ILEFT(I),K) + 1 WGTLON(I) * WORK(IRGHT(I),K) 50 CONTINUE GO TO 95 70 CONTINUE C.... POLEWARD EXTRAPOLATION INLAT = IABS(INSLAT(LAT)) DO 80 K=1,LEVS DO 80 I=1,IIN WORK(I,K) = XIN(I,K,INLAT)+WGTLAT(LAT) * 1 (XIN(I,K,INLAT) - XIN(I,K,INLAT+1)) 80 CONTINUE DO 90 K=1,LEVS DO 90 I=1,IOUT XOUT(I,K,LATOUT) = (1. E 0 - WGTLON(I)) * WORK(ILEFT(I),K) + 1 WGTLON(I) * WORK(IRGHT(I),K) 90 CONTINUE 95 CONTINUE CK100 FORMAT(1H ,' ROW =',I5,' LAT =',E15.5) RETURN END SUBROUTINE CDATE(JD,FJD,MUNTH,IM,ID,IYEAR,IHR,XMIN) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CDATE COMPUTES DAY,MONTH,YR FROM JULIAN DAY C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: THIS CODE WRITTEN AT GFDL .... C COMPUTES MONTH,DAY,YEAR FROM JULIAN DAY. C ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100.... C BASED ON JULIAN CALENDER CORRECTED TO CORRESPOND TO GREGORIAN C CALENDER DURING THIS PERIOD. C C PROGRAM HISTORY LOG: C 77-06-07 ROBERT WHITE,GFDL C C USAGE: CALL CDATE(JD,FJD,MUNTH,IM,ID,IYEAR,IHR,XMIN) C INPUT ARGUMENT LIST: C JD - JULIAN DAY FOR CURRENT FCST HOUR. C FJD - FRACTION OF THE JULIAN DAY. C OUTPUT ARGUMENT LIST: C MUNTH - MONTH (CHARACTER). C IM - MONTH (INTEGER). C ID - DAY OF THE MONTH. C IYEAR - YEAR. C IHR - HOUR OF THE DAY. C XMIN - MINUTE OF THE HOUR. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ C C ******************************************************************* C * * C * C D A T E * C * * C ******************************************************************* C C STATEMENTS BLOCKED BY ROBERT K. WHITE.......7 JUNE 1977 C C..... CDATE COMPUTES MONTH, DAY, AND YEAR FROM JULIAN DAY. C.....ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100 C.....BASED ON JULIAN CALENDER CORRECTED TO CORRESPOND TO GREGORIAN C.....CALENDER DURING THIS PERIOD C D I M E N S I O N 1 DY(13), MONTH(12) C C D A T A 1 DY / 2 0., 31., 59., 3 90., 120., 151., 4 181., 212., 243., 5 273., 304., 334., 6 365. / C D A T A 1 MONTH / 2 4HJAN., 4HFEB., 4HMAR., 3 4HAPR., 4HMAY , 4HJUNE, 4 4HJULY, 4HAUG., 4HSEP., 5 4HOCT., 4HNOV., 4HDEC. 6 / C C.....JDOR = JD OF DECEMBER 30, 1899 AT 12 HOURS UT C D A T A 1 JDOR / 2415019 /, 2 IYR / 1900 / C C ******************************************************************* C IYEAR=IYR NDAY=JD-JDOR IF(FJD.GE..5 E 0) NDAY=NDAY+1 61 IF(NDAY.LT.1462) GO TO 62 NDAY=NDAY-1461 IYEAR=IYEAR+4 GO TO 61 62 NDIY=365 IF(MOD(IYEAR,4).EQ.0) NDIY=366 IF(NDAY.LE.NDIY) GO TO 65 IYEAR=IYEAR+1 NDAY=NDAY-NDIY GO TO 62 65 IF(NDAY.GT.INT(DY(2))) GO TO 66 IM=1 ID=NDAY GO TO 67 66 IF(NDAY.NE.60) GO TO 68 IF(NDIY.EQ.365) GO TO 68 IM=2 ID=29 GO TO 67 68 IF(NDAY.GT.(INT(DY(3))+NDIY-365)) GO TO 69 IM=2 ID=NDAY-31 GO TO 67 69 DO 70 I=3,12 IF(NDAY.GT.(INT(DY(I+1))+NDIY-365)) GO TO 70 IM=I ID=NDAY-INT(DY(I))-NDIY+365 GO TO 67 70 CONTINUE 67 MUNTH=MONTH(IM) HR=24. E 0*FJD IHR=HR XMIN=60. E 0*(HR-FLOAT(IHR)) IHR=IHR+12 IF(IHR.GE.24) IHR=IHR-24 RETURN END SUBROUTINE COMPJD(JYR,JMNTH,JDAY,JHR,JMN,JD,FJD) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: COMPJD COMPUTES JULIAN DAY AND FRACTION C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: THIS CODE WRITTEN AT GFDL .... C COMPUTES JULIAN DAY AND FRACTION C FROM YEAR, MONTH, DAY AND TIME UT...ACCURATE ONLY BETWEEN C MARCH 1, 1900 AND FEBRUARY 28, 2100.. BASED ON JULIAN CALENDAR C CORRECTED TO CORRESPOND TO GREGORIAN CALENDAR DURING THIS PERIOD. C C PROGRAM HISTORY LOG: C 77-05-06 RAY ORZOL,GFDL C C USAGE: CALL COMPJD(JYR,JMNTH,JDAY,JHR,JMN,JD,FJD) C INPUT ARGUMENT LIST: C JYR - YEAR (4 DIGITS)-INTIAL FCST TIME. C JMNTH - MONTH-INITIAL FCST TIME. C JDAY - DAY-INITIAL FCST TIME. C JHR - Z-TIME OF INITIAL FCST TIME. C JMN - MINUTES (ZERO PASSED FROM CALLING PROGRAM). C OUTPUT ARGUMENT LIST: C JD - JULIAN DAY. C FJD - FRACTION OF THE JULIAN DAY. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ C ******************************************************************* C * C O M P J D * C * STATEMENT BLOCKED BY RAY ORZOL * C ******************************************************************* C D I M E N S I O N 1 NDM(12) C D A T A 1 JDOR/2415019/, 2 JYR19/1900/ C D A T A 1 NDM/0,31,59,90,120,151,181,212,243,273,304,334/ C ******************************************************************* C COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT C ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100 C BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN C CALENDAR DURING THIS PERIOD C JDOR=JD OF DECEMBER 30, 1899 AT 12 HOURS UT C ******************************************************************* JD=JDOR JYRM9=JYR-JYR19 LP=JYRM9/4 IF(LP.LE.0) GO TO 4 JD=JD+1461*LP 4 NY=JYRM9-4*LP IC=0 IF(NY.GT.0) GO TO 5 IF(JMNTH.GT.2) IC=1 GO TO 6 5 JD=JD+365*NY+1 6 JD=JD+NDM(JMNTH)+JDAY+IC IF(JHR.GE.12) GO TO 7 JD=JD-1 FJD=.5 E 0+.041666667 E 0*FLOAT(JHR)+.00069444444 E 0*FLOAT(JMN) RETURN 7 FJD=.041666667 E 0*FLOAT(JHR-12)+.00069444444 E 0*FLOAT(JMN) RETURN END SUBROUTINE FCSTIM(FHOUR,IMON,IDAY,IZTIM,JDNMC,FJDNMC,RLAG,YEAR, 1 RSIN1,RCOS1,RCOS2,JD,FJD) PARAMETER (TPI=2. E 0* 3.141593E+0 ) DIMENSION JMON(12) DATA JMON/31,28,31,30,31,30,31,31,30,31,30,31/ DATA TWO/2. E 0/ SAVE JMON,TWO C.... FIRST GET NUMBER OF DAYS SINCE BEGINNING OF YEAR (NO LEAP YRS) NNDAY =0 IMO = IMON - 1 IF (IMO.GT.0) THEN DO 150 I=1,IMO NNDAY = NNDAY + JMON(I) 150 CONTINUE ENDIF NNDAY = NNDAY + IDAY PRINT 1002,NNDAY 1002 FORMAT(1H ,'*************** NNDAY OF YEAR = ',I4,'******') C.... GET NUMBER OF DAYS INTO FCST (DYFCST) C.... FOLLOWING TWO CARDS CHANGED ON 10 APR 86 TO FIX SLIGHT ERROR C IN SOLAR DECLINATION CALC IF INITIAL HR NOT 00Z OR 12Z..... DAYINI = NNDAY + FLOAT(IZTIM)/24. E 0 SOLTIM = FHOUR + IZTIM C... RESET TO 24 HOUR CLOCK FDAY = SOLTIM / 24. E 0 C>YH SOLTIM = SOLTIM - INT(FDAY) * 24. E 0 DYFCST = NNDAY + FDAY PRINT 1003,JDNMC,FJDNMC,FHOUR,DAYINI,DYFCST 1003 FORMAT(1H0,'FROM HEATL3 JDNMC ETC',I9,2X,4(2X,F6.2)) RANG=TPI*(DYFCST-RLAG)/YEAR RSIN1=SIN(RANG) RCOS1=COS(RANG) RCOS2=COS(TWO*RANG) C.... UPDATE THE JULIAN DATE (INITIAL IN JDNMC,FJDNMC) DYINC = DYFCST - DAYINI IDYIN = DYINC FDYIN = DYINC - IDYIN JD = JDNMC + IDYIN FJD = FJDNMC + FDYIN C.......NEED TO RESET IF FRACTION (FJD) GT 1. IFJD = FJD IF (IFJD.GT.0) THEN JD = JD + IFJD FJD = FJD - IFJD ENDIF RETURN END SUBROUTINE SOLMRF(JD,FJD,R,DLT,ALP,SLAG,N,ALAT,HANG,TAUDA,COSZ) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SOLMRF ASTRONOMICAL(SOLAR) DATA - SW RADIATION C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: THIS IS A GFDL CODE .... C COMPUTES RADIUS VECTOR,DECLINATION AND RIGHT ASCENSION OF SUN, C EQUATION OF TIME, AND HOUR ANGLE OF SUN AT SUNSET FOR N EQUALLY C SPACED LATITUDES FOR GIVEN JULIAN DAY AND FRACTION..ALSO COMPUTES C DAYLIGHT LATITUDE MEAN COSINE SOLAR ZENITH ANGLE AND LATITUDINAL C AVERAGED FRACTIONAL DAYLIGHT. C C PROGRAM HISTORY LOG: C 77-07-21 ROBERT WHITE,GFDL. C 89-07-07 KENNETH CAMPANA-UPDATED-TO PASS ALAT THRU SUBROUTINE C CALL RATHER THAN LABELED COMMON. C C USAGE: CALL SOLMRF(JD,FJD,R,DLT,ALP,SLAG,N,ALAT,HANG,TAUDA,COSZ) C INPUT ARGUMENT LIST: C JD - JULIAN DAY FOR CURRENT FCST HOUR. C FJD - FRACTION OF THE JULIAN DAY. C N - NUMBER OF GAUSSIAN LATIUTUDES + 2 (FOR THE POLES). C ALAT - GAUSSIAN LATITUDES + 2 (POLES) IN RADIANS. C OUTPUT ARGUMENT LIST: C R - RADIUS VECTOR OF THE SUN. C DLT - DECLINATION OF THE SUN (RADIANS). C ALP - RIGHT ASCENSION OF THE SUN. C SLAG - EQUATION OF TIME (RADIANS). C HANG - HOUR ANGLE OF SUN AT SUNSET (FOR N LATS). C TAUDA - LATITUDINAL AVER. FRACTIONAL DAYLIGHT (FOR N LATS). C COSZ - LATITUDINAL DAYLIGHT-MEAN COSINE SOLAR ZENITH ANGLE. C C OUTPUT FILES: C OUTPUT - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ PARAMETER (PI= 3.141593E+0 ,TPI=2.0*PI,HPI=0.5*PI,RAD=180.0/PI) C C C ******************************************************************* C * S O L M R F * C... * ORIGINAL GFDL CODE (EXCEPT FOR PASSING ALAT IN CALL LIST)-- * C * I.E. COMPUTES GAUSSIAN LATITUDE MEAN COSINE SOLAR ZEN ANGLE * C * UPDATES BY HUALU PAN TO LIMIT ITERATIONS IN NEWTON METHOD AND * C * ALSO CCR REDUCED FROM(1.3E-7)--BOTH TO AVOID NONCONVERGENCE IN * C * NMC S HALF PRECISION VERSION OF GFDL S CODE ---- FALL 1988 * C ******************************************************************* C C STATEMENTS BLOCKED BY ROBERT K. WHITE.......21 JULY 1977 C C C.....SOLMRF COMPUTES RADIUS VECTOR, DECLINATION AND RIGHT ASCENSION OF C.....SUN, EQUATION OF TIME, AND HOUR ANGLE OF SUN AT SUNSET FOR N C.....EQUALLY SPACED LATITUDES GIVEN JULIAN DAY AND FRACTION. C D I M E N S I O N 1 ALAT(N), HANG(N), COSZ(N), TAUDA(N) C D A T A 1 CYEAR/365.25/, CCR/1.3 E -6/ C C.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900 C.....SVT6 = DAYS BETWEEN PERIHELION PASSAGE AND MARCH EQUINOX OF 1900 C.....JDOR = JD OF EPOCH WHICH IS JANUARY 0, 1900 AT 12 HOURS UT C D A T A 1 TPP/1.55/, SVT6/78.035/, JDOR/2415020/ C C ******************************************************************* C DAT=FLOAT(JD-JDOR)-TPP+FJD C COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH T=FLOAT(JD-JDOR)/36525. E 0 C COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS) YEAR=.25964134 E 0+.304 E -5*T TYEAR=.24219879 E 0-.614 E -5*T C COMPUTES ORBIT ECCENTRICITY AND ANGLE OF EARTH'S INCLINATION FROM T EC=.01675104 E 0-(.418 E -4+.126 E -6*T)*T ANGIN=23.452294 E 0-(.0130125 E 0+.164 E -5*T)*T ADOR=JDOR JDOE=ADOR+(SVT6*CYEAR)/(YEAR-TYEAR) C DELEQN=UPDATED SVT6 FOR CURRENT DATE DELEQN=FLOAT(JDOE-JD)*(YEAR-TYEAR)/CYEAR YEAR=YEAR+365. E 0 SNI=SIN(ANGIN/RAD) TINI=1. E 0/TAN(ANGIN/RAD) ER=SQRT((1. E 0+EC)/(1. E 0-EC)) QQ=DELEQN*TPI/YEAR C DETERMINE TRUE ANOMALY AT EQUINOX E=1. E 0 ITER = 0 32 EP=E-(E-EC*SIN(E)-QQ)/(1. E 0-EC*COS(E)) CD=ABS(E-EP) E=EP ITER = ITER + 1 IF(ITER.GT.10) THEN WRITE(6,*) ' ITERATION COUNT FOR LOOP 32 =', ITER WRITE(6,*) ' E, EP, CD =', E, EP, CD ENDIF IF(ITER.GT.10) GOTO 1032 IF(CD.GT.CCR) GO TO 32 1032 CONTINUE HE=.5 E 0*E EQ=2. E 0*ATAN(ER*TAN(HE)) C DATE=DAYS SINCE LAST PERIHELION PASSAGE DATE = MOD(DAT,YEAR) C SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD EM=TPI*DATE/YEAR E=1. E 0 ITER = 0 31 EP=E-(E-EC*SIN(E)-EM)/(1. E 0-EC*COS(E)) CR=ABS(E-EP) E=EP ITER = ITER + 1 IF(ITER.GT.10) THEN WRITE(6,*) ' ITERATION COUNT FOR LOOP 31 =', ITER ENDIF IF(ITER.GT.10) GOTO 1031 IF(CR.GT.CCR) GO TO 31 1031 CONTINUE R=1. E 0-EC*COS(E) HE=.5 E 0*E W=2. E 0*ATAN(ER*TAN(HE)) SIND=SNI*SIN(W-EQ) DLT=ASIN(SIND) ALP=ASIN(TAN(DLT)*TINI) TST=COS(W-EQ) IF(TST.LT.0. E 0) ALP=PI-ALP IF(ALP.LT.0. E 0) ALP=ALP+TPI SUN=TPI*(DATE-DELEQN)/YEAR IF(SUN.LT.0. E 0) SUN=SUN+TPI SLAG=SUN-ALP-.03255 E 0 C COMPUTE HOUR ANGLE OF SUNSET AT ALL LATITUDES IF(DLT.EQ.0. E 0) THEN DO 10 I=1,N HANG(I)=HPI TAUDA(I)=0.5 E 0 COSZ(I)= MAX (COS(ALAT(I)/HPI),0. E 0) 10 CONTINUE ELSE DO 1 I=1,N SS=SIN(ALAT(I))*SIN(DLT) CC=COS(ALAT(I))*COS(DLT) AP=ABS(ALAT(I)) EPS=ABS(AP-HPI) IF(EPS.GT.CCR) GO TO 14 HANG(I)=HPI*ABS(AP/ALAT(I)+ABS(DLT)/DLT) GO TO 5 14 AR=-SS/CC AC=ABS(AR) IF(AC+CCR.GT.1. E 0) GO TO 3 IF(AC+CCR.LT.1. E 0) GO TO 4 2 HANG(I)=(AC-AR)*HPI GO TO 5 3 IF(AR.LT.0. E 0) GO TO 25 HANG(I)=0. GO TO 5 25 HANG(I)=PI GO TO 5 4 HANG(I)=ACOS(AR) 5 TAUDA(I)= MAX (HANG(I)/PI,0. E 0) IF(HANG(I).EQ.0. E 0) GO TO 100 COSZ(I)= MAX ((SS+CC*SIN(HANG(I))/HANG(I)),0. E 0) GO TO 1 100 COSZ(I)=0. E 0 1 CONTINUE ENDIF RETURN END SUBROUTINE SOLAR(JD,FJD,R,DLT,ALP,SLAG,SDEC,CDEC) C>YH SUBROUTINE SOLAR(JD,FJD,R,DLT,ALP,SLAG) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SOLAR ASTRONOMICAL(SOLAR) DATA - SW RADIATION C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: THIS CODE WRITTEN AT GFDL .... C COMPUTES RADIUS VECTOR,DECLINATION AND RIGHT ASCENSION OF SUN, C AND EQUATION OF TIME. SAME AS SUBROUTINE -SOLMRF-, BUT C WITH HOUR ANGLE,FRACTIONAL DAYLIGHT,AND C MEAN ZENITH ANGLE CALCULATIONS REMOVED (SUBROUTINE -ZENITH- C CALCULATES THESE FOR EACH POINT RATHER THAN EACH LATITUDE). C --THIS CODE IS TO BE USED FOR OTHER FCST MODELS OR FOR THE MRF C --MODEL IF 'INSTANTANEOUS' SW CALCULATIONS DESIRED. C C PROGRAM HISTORY LOG: C 77-07-21 ROBERT WHITE,GFDL. C 89-07-07 KENNETH CAMPANA-MOVED THE HOUR ANGLE CALCULATIONS TO C SUBROUTINE -ZENITH- C C USAGE: CALL SOLMRF(JD,FJD,R,DLT,ALP,SLAG) C INPUT ARGUMENT LIST: C JD - JULIAN DAY FOR CURRENT FCST HOUR. C FJD - FRACTION OF THE JULIAN DAY. C OUTPUT ARGUMENT LIST: C R - RADIUS VECTOR OF THE SUN. C DLT - DECLINATION OF THE SUN (RADIANS). C ALP - RIGHT ASCENSION OF THE SUN. C SLAG - EQUATION OF TIME (RADIANS). C C OUTPUT FILES: C OUTPUT - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ PARAMETER (PI= 3.141593E+0 ,TPI=2.0*PI,HPI=0.5*PI,RAD=180.0/PI) C C C ******************************************************************* C * S O L A R * C... * PATTERNED AFTER ORIGINAL GFDL CODE--- * C... * BUT NO CALCULATION OF LATITUDE MEAN COS SOLAR ZENITH ANGLE..* C... * ZENITH ANGLE CALCULATIONS DONE IN SUBR ZENITH IN THIS CASE..* C... * HR ANGLE,MEAN COSZ,AND MEAN TAUDA CALC REMOVED--K.A.C. MAR 89 * C * UPDATES BY HUALU PAN TO LIMIT ITERATIONS IN NEWTON METHOD AND * C * ALSO CCR REDUCED FROM(1.3E-7)--BOTH TO AVOID NONCONVERGENCE IN * C * NMC S HALF PRECISION VERSION OF GFDL S CODE ---- FALL 1988 * C ******************************************************************* C C.....SOLAR COMPUTES RADIUS VECTOR, DECLINATION AND RIGHT ASCENSION OF C.....SUN, EQUATION OF TIME C D A T A 1 CYEAR/365.25/, CCR/1.3 E -6/ C C.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900 C.....SVT6 = DAYS BETWEEN PERIHELION PASSAGE AND MARCH EQUINOX OF 1900 C.....JDOR = JD OF EPOCH WHICH IS JANUARY 0, 1900 AT 12 HOURS UT C D A T A 1 TPP/1.55/, SVT6/78.035/, JDOR/2415020/ C C ******************************************************************* C DAT=FLOAT(JD-JDOR)-TPP+FJD C COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH T=FLOAT(JD-JDOR)/36525. E 0 C COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS) YEAR=.25964134 E 0+.304 E -5*T TYEAR=.24219879 E 0-.614 E -5*T C COMPUTES ORBIT ECCENTRICITY AND ANGLE OF EARTH'S INCLINATION FROM T EC=.01675104 E 0-(.418 E -4+.126 E -6*T)*T ANGIN=23.452294 E 0-(.0130125 E 0+.164 E -5*T)*T ADOR=JDOR JDOE=ADOR+(SVT6*CYEAR)/(YEAR-TYEAR) C DELEQN=UPDATED SVT6 FOR CURRENT DATE DELEQN=FLOAT(JDOE-JD)*(YEAR-TYEAR)/CYEAR YEAR=YEAR+365. E 0 SNI=SIN(ANGIN/RAD) TINI=1. E 0/TAN(ANGIN/RAD) ER=SQRT((1. E 0+EC)/(1. E 0-EC)) QQ=DELEQN*TPI/YEAR C DETERMINE TRUE ANOMALY AT EQUINOX E=1. E 0 ITER = 0 32 EP=E-(E-EC*SIN(E)-QQ)/(1. E 0-EC*COS(E)) CD=ABS(E-EP) E=EP ITER = ITER + 1 IF(ITER.GT.10) THEN WRITE(6,*) ' ITERATION COUNT FOR LOOP 32 =', ITER WRITE(6,*) ' E, EP, CD =', E, EP, CD ENDIF IF(ITER.GT.10) GOTO 1032 IF(CD.GT.CCR) GO TO 32 1032 CONTINUE HE=.5 E 0*E EQ=2. E 0*ATAN(ER*TAN(HE)) C DATE=DAYS SINCE LAST PERIHELION PASSAGE DATE = MOD(DAT,YEAR) C SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD EM=TPI*DATE/YEAR E=1. E 0 ITER = 0 31 EP=E-(E-EC*SIN(E)-EM)/(1. E 0-EC*COS(E)) CR=ABS(E-EP) E=EP ITER = ITER + 1 IF(ITER.GT.10) THEN WRITE(6,*) ' ITERATION COUNT FOR LOOP 31 =', ITER ENDIF IF(ITER.GT.10) GOTO 1031 IF(CR.GT.CCR) GO TO 31 1031 CONTINUE R=1. E 0-EC*COS(E) HE=.5 E 0*E W=2. E 0*ATAN(ER*TAN(HE)) C>YH SIND=SNI*SIN(W-EQ) C>YH DLT=ASIN(SIND) SDEC=SNI*SIN(W-EQ) CDEC=SQRT(1. E 0 - SDEC*SDEC) DLT=ASIN(SDEC) ALP=ASIN(TAN(DLT)*TINI) TST=COS(W-EQ) IF(TST.LT.0. E 0) ALP=PI-ALP IF(ALP.LT.0. E 0) ALP=ALP+TPI SUN=TPI*(DATE-DELEQN)/YEAR IF(SUN.LT.0. E 0) SUN=SUN+TPI SLAG=SUN-ALP-.03255 E 0 RETURN END SUBROUTINE PRTIME(ID,MUNTH,IYEAR,IHR,XMIN,JD,FJD, 1 DLT,ALF,R1,SLAG,SOLC) PARAMETER (DEGRAD=180. E 0/ 3.141593E+0 ,HPI=0.5 E 0* 3.141593E+0 1) DATA SIGN/1H-/, SIGB/1H / DATA ZERO,SIX,SIXTY,Q22855/0.0,6.0,60.0,228.55735/ SAVE SIGN,ZERO,SIX,SIXTY,Q22855 DLTD=DEGRAD*DLT LTD=DLTD DLTM=SIXTY*(ABS(DLTD)-ABS(FLOAT(LTD))) LTM=DLTM DLTS=SIXTY*(DLTM-FLOAT(LTM)) DSIG=SIGB IF((DLTD.LT.ZERO).AND.(LTD.EQ.0)) DSIG=SIGN HALP=SIX*ALF/HPI IHALP=HALP YMIN=ABS(HALP-FLOAT(IHALP))*SIXTY IYY=YMIN ASEC=(YMIN-FLOAT(IYY))*SIXTY EQT=Q22855*SLAG EQSEC=SIXTY*EQT PRINT 1004, ID,MUNTH,IYEAR,IHR,XMIN,JD,FJD,R1,HALP,IHALP, 1 IYY,ASEC,DLTD,DSIG,LTD,LTM,DLTS,EQT,EQSEC,SLAG,SOLC 1004 FORMAT('0 FORECAST DATE',9X,I3,A5,I6,' AT',I3,' HRS',F6.2,' MINS'/ 1 ' JULIAN DAY',12X,I8,2X,'PLUS',F11.6/ 2 ' RADIUS VECTOR',9X,F10.7/ 3 ' RIGHT ASCENSION OF SUN',F12.7,' HRS, OR',I4,' HRS',I4, 4 ' MINS',F6.1,' SECS'/ 5 ' DECLINATION OF THE SUN',F12.7,' DEGS, OR',A2,I3, 6 ' DEGS',I4,' MINS',F6.1,' SECS'/ 7 ' EQUATION OF TIME',6X,F12.7,' MINS, OR',F10.2,' SECS, OR' 8 ,F9.6,' RADIANS'/ 9 ' SOLAR CONSTANT',8X,F12.7//) RETURN END SUBROUTINE ZENITH(FJD,DLT,SLAG,RLAT,RLON,HANG,DHR,NLNG,COSZ,FRAC) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ZENITH COMPUTE COSINE SOLAR ZENITH ANGLE C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: THIS CODE WRITTEN AT GFDL ..... C COMPUTES EFFECTIVE MEAN (OVER SPECIFIED INTERVAL,DHR) C COSINE OF ZENITH ANGLE AND DAYLIGHT FRACTION C FROM LATITUDE,LONGITUDE,AND COMPUTED HOUR ANGLE OF SUNSET. C INPUT ARGUMENTS TO CIRCULAR FUNCTIONS ARE IN RADIANS. C C PROGRAM HISTORY LOG: C 77-10-19 ROBERT WHITE,GFDL. C 89-07-07 KENNETH CAMPANA-UPDATED-TO CALCULATE SUNSET HOUR ANGLE C HERE RATHER THAN IN SUBR-SOLAR- C C USAGE: CALL ZENITH(FJD,DLT,SLAG,XLAT,XLON,HANG,DHR,NLNG, C COSZ,FRAC) C INPUT ARGUMENT LIST: C FJD - FRACTION OF THE JULIAN DAY. C DLT - DECLINATION OF THE SUN (RADIANS). C SLAG - EQUATION OF TIME (RADIANS). C XLAT - LATITUDE (DEGREES) FOR EACH OF THE NLNG PTS. C XLON - LONGITUDE (DEGREES) FOR EACH OF THE NLNG PTS. C DHR - INTERVAL (HOURS) OVER WHICH TO AVERAGE COSZ,FRAC. C NLNG - NUMBER OF POINTS IN LONGITUDINAL DIRECTION. C OUTPUT ARGUMENT LIST: C HANG - HOUR ANGLE OF SUN AT SUNSET. C COSZ - TEMPORAL MEAN COSINE SOLAR ZENITH ANGLE. C FRAC - TEMPORAL AVERAGE FRACTIONAL DAYLIGHT. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ PARAMETER (PI= 3.141593E+0 ,TPI=2.0*PI,PID24=PI/24.0,HPI=0.5*PI) C C ******************************************************************* C * Z E N I T H * C * STATEMENTS BLOCKED BY ROBERT K. WHITE.......19 OCT. 1977 * C * INPUT LAT/LON DEG(XLAT,XLON),COMPUTE SUNSET HR ANGL KAC MAR89* C ******************************************************************* C D I M E N S I O N 1 COSZ(NLNG), FRAC(NLNG) DIMENSION RLAT(NLNG),RLON(NLNG),HANG(NLNG) C L O G I C A L 1 RISE, SET C D A T A 1 CCR/1.3 E -6/ C C ******************************************************************* C C ZENITH COMPUTES EFFECTIVE MEAN COSINE OF ZENITH ANGLE AND DAYLIGHT C FRACTION FROM LATITUDE AND COMPUTED HOUR ANGLE OF SUNSET(THE C LATTER IS OBTAINED FROM SUBROUTINE SOLAR).. C--- INPUT ARGUMENTS TO CIRCULAR FUNCTIONS ARE IN RADIANS. C CVPR=TPI/FLOAT(NLNG/2) GHA=FJD*TPI+SLAG ARG=DHR*PID24 SINFAC=SIN(ARG)/ARG IF(DLT.EQ.0. E 0) THEN DO 60 I=1,NLNG CC=COS(RLAT(I)) HANG(I) = HPI CONS=CC/HPI CKAC XLNG = CVPR * (FLOAT(I) - 1. E 0) HLOC=GHA+RLON(I)+ARG C LOCAL HOUR ANGLE SHIFTED BY HALF OF THE AVERAGING PERIOD HLOC = MOD(HLOC,TPI) IF(HLOC.GT.PI) HLOC=HLOC-TPI HLPAR=HLOC+ARG ARMHL=ARG-HLOC SET=HLPAR.GT.HPI RISE=ARMHL.GT.HPI IF(RISE.AND.SET) GO TO 57 IF(HLPAR.GT.PI) GO TO 58 IF(ARMHL.GT.PI) GO TO 59 IF(SET) GO TO 53 IF(RISE) GO TO 54 FRAC(I)=1. E 0 COSZ(I)=CC*COS(HLOC)*SINFAC GO TO 52 53 DELSH=.5 E 0*(HPI+ARMHL) GO TO 55 54 DELSH=.5 E 0*(HPI+HLPAR) 55 IF(DELSH.LE.0. E 0) GO TO 56 FRAC(I)=DELSH/ARG COSZ(I)=CC*COS(HPI-DELSH)*SIN(DELSH)/DELSH GO TO 52 57 FRAC(I)=HPI/ARG COSZ(I)=CONS GO TO 52 58 DELE=.5 E 0 * MAX (HLPAR+HPI-TPI,0. E 0) DELW=.5 E 0 * MAX (HPI+ARMHL,0. E 0) GO TO 70 59 DELE=.5 E 0 * MAX (HPI+HLPAR,0. E 0) DELW=.5 E 0 * MAX (ARMHL+HPI-TPI,0. E 0) 70 FRAC(I)=(DELE+DELW)/ARG IF(FRAC(I).EQ.0. E 0) GO TO 71 COSZ(I)=CC*(COS(HPI-DELE)*SIN(DELE)+ 1 COS(HPI-DELW)*SIN(DELW))/(DELE+DELW) GO TO 52 56 FRAC(I)=0. E 0 71 COSZ(I)=0. E 0 52 CONTINUE COSZ(I) = MIN (1. E 0,COSZ(I)) COSZ(I) = MAX (0. E 0,COSZ(I)) FRAC(I) = MIN (1. E 0,FRAC(I)) 60 CONTINUE ELSE DO 20 I=1,NLNG C... COMPUTE HOUR ANGLE OF SUNSET FOR EACH POINT SS=SIN(RLAT(I))*SIN(DLT) CC=COS(RLAT(I))*COS(DLT) IF(DLT.EQ.0. E 0) GO TO 16 AP=ABS(RLAT(I)) EPS=ABS(AP-HPI) IF(EPS.GT.CCR) GO TO 14 HANG(I)=HPI*ABS(AP/RLAT(I)+ABS(DLT)/DLT) GO TO 35 14 AR=-SS/CC AC=ABS(AR) IF(AC+CCR.GT.1. E 0) GO TO 33 IF(AC+CCR.LT.1. E 0) GO TO 34 32 HANG(I)=(AC-AR)*HPI GO TO 35 33 IF(AR.LT.0. E 0) GO TO 25 HANG(I)=0. GO TO 35 25 HANG(I)=PI GO TO 35 16 HANG(I)=HPI GO TO 35 34 HANG(I)=ACOS(AR) 35 HA=HANG(I) IF(HA.GT.0. E 0) CONS=SS+CC*SIN(HA)/HA CKAC XLNG = CVPR * (FLOAT(I) - 1. E 0) HLOC=GHA+RLON(I)+ARG C LOCAL HOUR ANGLE SHIFTED BY HALF OF THE AVERAGING PERIOD HLOC = MOD(HLOC,TPI) IF(HLOC.GT.PI) HLOC=HLOC-TPI HLPAR=HLOC+ARG ARMHL=ARG-HLOC SET=HLPAR.GT.HA RISE=ARMHL.GT.HA IF(RISE.AND.SET) GO TO 7 IF(HLPAR.GT.PI) GO TO 8 IF(ARMHL.GT.PI) GO TO 9 IF(SET) GO TO 3 IF(RISE) GO TO 4 FRAC(I)=1. E 0 COSZ(I)=SS+CC*COS(HLOC)*SINFAC GO TO 2 3 DELSH=.5 E 0*(HA+ARMHL) GO TO 5 4 DELSH=.5 E 0*(HA+HLPAR) 5 IF(DELSH.LE.0. E 0) GO TO 6 FRAC(I)=DELSH/ARG COSZ(I)=SS+CC*COS(HA-DELSH)*SIN(DELSH)/DELSH GO TO 2 7 IF(HA.LE.0. E 0) GO TO 6 FRAC(I)=HA/ARG COSZ(I)=CONS GO TO 2 8 DELE=.5 E 0 * MAX (HLPAR+HA-TPI,0. E 0) DELW=.5 E 0 * MAX (HA+ARMHL,0. E 0) GO TO 10 9 DELE=.5 E 0 * MAX (HA+HLPAR,0. E 0) DELW=.5 E 0 * MAX (ARMHL+HA-TPI,0. E 0) 10 FRAC(I)=(DELE+DELW)/ARG IF(FRAC(I).EQ.0. E 0) GO TO 11 COSZ(I)=SS+CC*(COS(HA-DELE)*SIN(DELE)+ 1 COS(HA-DELW)*SIN(DELW))/(DELE+DELW) GO TO 2 6 FRAC(I)=0. E 0 11 COSZ(I)=0. E 0 2 CONTINUE COSZ(I) = MIN (1. E 0,COSZ(I)) COSZ(I) = MAX (0. E 0,COSZ(I)) FRAC(I) = MIN (1. E 0,FRAC(I)) 20 CONTINUE ENDIF RETURN END SUBROUTINE ALBSNO(IMX2,LAT,JSNO, 1 ALBDOA,RLAT,ALBEDR,SLMSKR,SSNOW,TGR,TAR) CFPP$ NOCONCUR R DIMENSION ALBDOA(IMX2),ALBEDR(IMX2),SLMSKR(IMX2) DIMENSION SSNOW(IMX2),RLAT(IMX2) C ADDED BY BOB GRUMBINE FOR SEA ICE ALBEDO ALGORITHM REAL TGR(IMX2), TAR(IMX2) C MODIFIED BY HMH JUANG FOR SIMPLICITY AND FOR REGIONAL MODEL USE PARAMETER(SNODEG=70.* 3.141593E+0 /180.) C.... C THE FOLLOWING DETERMINES SURFACE ALBEDO (ALBDOA),WHERE SNOW EXISTS. C.... SNOCHK= 3.141593E+0 IF(JSNO.EQ.0) SNOCHK=SNODEG ! JSNO=0 FOR RSM C DO 350 I=1, IMX2 C.... LIMIT BACKGROUND ALBEDO (IN CASE SNOW LEAVES GREENLAND) ALBDOA(I)=MIN(ALBEDR(I),0.6 E 0) CKAC..... IF(TSEAR(I).LE.0. E 0) GO TO 34 IF(SLMSKR(I).EQ.1.0 E 0) THEN C... CHECK LATSNODEG FOR REGIONAL IF(LAT.LT.JSNO .OR. ABS(RLAT(I)).GT.SNOCHK) THEN IF(SSNOW(I).GT.0. E 0) ALBDOA(I)=0.75 E 0 ELSE IF(SSNOW(I).GE.1. E 0) THEN ALBDOA(I)=0.6 E 0 ELSE IF(SSNOW(I).GT.0.0 E 0) THEN ALBDOA(I)=ALBDOA(I)+SQRT(SSNOW(I))*(0.6 E 0-ALBDOA(I)) ENDIF ENDIF CKAC.......34 IF (TSEAR(I).LE.-271.21 E 0) GO TO 35 ELSE IF(SLMSKR(I).EQ.2.0 E 0) THEN CKAC ALBDOA(I)=0.5 E 0 CKAC IF(SSNOW(I).GT.0. E 0) ALBDOA(I)=0.75 E 0 IF (SSNOW(I) .GT. 0.0) THEN IF (TGR(I) .LT. 273.16 - 5.) THEN ALBDOA(I) = 0.8 ELSE IF (TGR(I) .LE. 273.16) THEN ALBDOA(I) = 0.65 + 0.03*(273.16 - TGR(I)) ELSE ALBDOA(I) = 0.65 ENDIF ELSE IF (TGR(I) .LT. 271.2 .OR. TAR(I) .LT. 273.16) THEN ALBDOA(I) = 0.65 ELSE IF (TAR(I) .LT. 273.16+5.) THEN ALBDOA(I) = 0.65 - 0.04*(TAR(I) -273.16) ELSE ALBDOA(I) = 0.45 ENDIF ENDIF ENDIF ALBDOA(I) = MAX(ALBDOA(I),.06 E 0) 350 CONTINUE RETURN END SUBROUTINE ZONGRD(A,ZONA,ZONB) CFPP$ NOCONCUR R DIMENSION A( 384 , 28 ),ZONA( 28 ),ZONB( 28 ) DO 3 K=1, 28 ZONA(K)=0. E 0 ZONB(K)=0. E 0 DO 2 I=1, 192 ZONA(K)=ZONA(K)+A(I,K) ZONB(K)=ZONB(K)+A(I+ 192 ,K) 2 CONTINUE ZONA(K)=ZONA(K)/ 192 ZONB(K)=ZONB(K)/ 192 3 CONTINUE C PRINT 100,J,ZON C100 FORMAT(1H ,I3, 28 (1X,F5.2)) RETURN END SUBROUTINE EXTRM1(A,LGTH,IND) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: EXTREM PRINTS MINIMUMS AND MAXIMUMS OF 2 ARRAYS. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-01 C C ABSTRACT: PRINTS MINIMUMS AND MAXIMUMS OF 2 ARRAYS. C C PROGRAM HISTORY LOG: C 88-04-01 JOSEPH SELA C C USAGE: CALL EXTREM (A, B, LGTH, IND) C INPUT ARGUMENT LIST: C A - FINDS AND PRINTS MINIMUM AND MAXIMUM OF ARRAY A. C B - FINDS AND PRINTS MINIMUM AND MAXIMUM OF ARRAY B. C LGTH - LENGTH OF ARRAY A AND ARRAY B. C IND - INDICATOR PRINTED WITH MINIMUMS AND MAXIMUMS. C C OUTPUT FILES: C OUTPUT - PRINTOUT FILE. C C REMARKS: LGTH SHOULD BE GREATER THAN 1. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200 C MACHINE: CYBER 205 C C$$$ DIMENSION A(LGTH) AMIN = A(1) AMAX = A(1) DO 25 I=2,LGTH IF (A(I).GT.AMAX) AMAX = A(I) IF (A(I).LT.AMIN) AMIN = A(I) 25 CONTINUE C PRINT 100,IND,AMIN,AMAX 100 FORMAT(1H ,'IND AMIN AMAX ',I4,2X,2(E12.4,2X)) RETURN END SUBROUTINE EXTRM2(NGG,NGGS,A,AMIN,AMAX,B,BMIN,BMAX,LGTH,IND) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: EXTREM PRINTS MINIMUMS AND MAXIMUMS OF 2 ARRAYS. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-01 C C ABSTRACT: PRINTS MINIMUMS AND MAXIMUMS OF 2 ARRAYS. C C PROGRAM HISTORY LOG: C 88-04-01 JOSEPH SELA C C USAGE: CALL EXTREM (A, B, LGTH, IND) C INPUT ARGUMENT LIST: C A - FINDS AND PRINTS MINIMUM AND MAXIMUM OF ARRAY A. C B - FINDS AND PRINTS MINIMUM AND MAXIMUM OF ARRAY B. C LGTH - LENGTH OF ARRAY A AND ARRAY B. C IND - INDICATOR PRINTED WITH MINIMUMS AND MAXIMUMS. C C OUTPUT FILES: C OUTPUT - PRINTOUT FILE. C C REMARKS: LGTH SHOULD BE GREATER THAN 1. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200 C MACHINE: CYBER 205 C C$$$ DIMENSION A(LGTH), B(LGTH) DO 25 I=1,LGTH IF (A(I).GT.AMAX) AMAX = A(I) IF (A(I).LT.AMIN) AMIN = A(I) 25 CONTINUE C DO 50 I=1,LGTH IF (B(I).GT.BMAX) BMAX = B(I) IF (B(I).LT.BMIN) BMIN = B(I) 50 CONTINUE IF(NGG.EQ.NGGS) PRINT 100,IND,AMIN,AMAX,BMIN,BMAX 100 FORMAT(1H ,'IND AMIN AMAX BMIN BMAX ',I4,2X,4(E12.4,2X)) RETURN END CFPP$ EXPAND(FPVS) SUBROUTINE CLDJMS(IMX2,IMX22,KMX,NBIN,MCLD, 1 PS,Q,T,VVEL,CV,CVT,CVB,SI,SL, 1 SLMSK,CLD,MTOP,MBOT,CLDARY,IVVA,INVR,RHMAX, 2 XLATRD,RHCLD,ISTRAT) CTUNE CFPP$ NOCONCUR R C.... FROM YH.RAD.MDL93(CLDNEW28)....... C.... LATER UPDATED FROM YH.RAD.MDL94(CLDMUL28)...22JAN94 C.... LATER UPDATED FROM YH.RAD.MDL94(CLDML28A)... 1FEB94 C.... LATER UPDATED FROM YH.RAD.MDL94(CLDML28B)... 5FEB94 C. SUBR CLDPRP REPLACED C. ADDED VERTICAL INTERP OF CLD-RH RELATIONS(ISTRAT GT 1) C.... LATER UPDATED FROM YH.RAD.MDL94(CLDML28E)... 11MAR94 C. SUBR CLDPRP REPLACED,GCL ADJUSTED C.... LATER UPDATED FROM CLOUD6................... 24MAR94 C. SUBR CLDPRP , LOW ENHANCED TO OLD VALUE..0.14.. C. SUBR GCLNEW , LLYR CALCULATION ADJ TO OLD VALU(KL-1) C. LLYRL WAS OK.. IVE REMOVED IT AND C. REPLACED IT BY ITS EQUIVALENT, KLOWB C.... LATER UPDATED FROM CLOUD6................... 30MAR94 C. SUBR CLDPRP , LOW AND MIDDLE (NOT CV) ENHANCED=0.10 C--------------------------------------------------------------------- C NOV., 1992 - Y.H., K.A.C., AND A.K. C CLOUD PARAMETERIZATION PATTERNED AFTER SLINGO AND SLINGO'S C WORK (JGR, 1991). C STRATIFORM CLOUDS ARE ALLOWED IN ANY LAYER EXCEPT THE SURFACE C AND UPPER STRATOSPHERE. THE RELATIVE HUMIDITY CRITERION MAY C VARY IN DIFFERENT MODEL LAYERS. CYH94 C OUTPUT CLOUD AMOUNTS ARE IN CLDARY(I,K), K=1 IS THE LOWEST C MODEL LAYER, STRATIFORM (STR) AND CONVECTIVE (CNV) TYPES OF C CLOUD ARE COMPRESSED INTO ONE WORD: CAMT = STR + 1.0E4*CNV C LOW MARINE STRATUS AMT'S ARE FLAGED BY ADDING 2. CYH94 CTUNE C.. FOR ISTRAT = 0, THERE IS RH-CLD RELATION FOR EACH LAYER.. C CRIT RH COMPUTED WITHIN.. C.. FOR ISTRAT = 1, RH-CLD RELATION FROM TABLES CREATED USING C MITCHELL-HAHN TUNING TECHNIQUE (A.F. RTNEPH OBS) C ...STRATUS COMPUTED SIMILAR TO OLD OPNL CLDJMS..... C EXCEPT NO CLOUD BELOW LAYER=KLOWB..APPROX 955MB CTUNE C CONVECTIVE CLOUDS ARE FROM MODEL CONVECTIVE SCHEME AND ARE C NO LONGER BROKEN INTO .75,.25,.25..RATHER CC ITSELF IS USED.. C CONVECTIVE STILL TAKES PRECEDENCE OVER STRATIFORM IN RADFS C BUT HERE CV+ST MERGE EXITS IN CLDARY...(IN RADIATION USE OF C CC GIVES IMPROVEMENT TO TROPICAL MIDDLE CLD (AS DID ST+CV)) C C CLOUDS ARE ALSO DIVIDED INTO 3 ATMOSPHERIC DOMAINS (L,M,H) FOR C DIAGNOSTIC PURPOSES. THEY ARE COMPUTED FROM RANDOM OVERLAP C ASSUMPTION FOR SEPARATED CLOUD LAYERS AND MAXIMUM OVERLAP C FOR ADJACENT CLOUD LAYERS. A TOTAL CLOUD FRACTION IS ALSO C COMPUTED. C C H,M,L DOMAIN PRESSURE TOPS 'PTOP1(K)' VARY LINEARLY FROM C 'PTOPC(K,1)' AT 45DEG TO 'PTOPC(K,2)' AT THE POLE C C-------------------------------------------------------------------- C INPUT VARIABLES: C PS (CB) - SURFACE PRESSURE C Q (KG/KG) - SPECIFIC HUMIDITY C T (DEG K) - ABSOLUTE TEMPERATURE C VVEL(CB/SEC) - VERTICAL VELOCITY C CV,CVT,CVB - CONV CLD FRACTION, TOP, BOTTOM LAYER FROM C KUO SCHEME C SI,SL - MDL SIGMA INTERFACE AND LAYER MEAN C SLMSK - SEA/LAND MASK ARRAY(SEA:0.,LAND:1.,SNOW:2.) C IVVA - FLAG TO CONTROL VERTICAL VELOCITY ADJ. C =1: WITH, =0: WITHOUT C INVR - FLAG TO CONTROL LAPSE RATE INVERSION CLD C =1: WITH, =0: WITHOUT C RHMAX - UPPER LIMIT OF RELATIVE HUMIDITY TO C FORM OVERCAST CLOUD (CLD FRACTN = 1.) CTUNE C --------------- MODIFY TO AS AN ARRAY (H.-M. H. JUANG) C********XLATRD - CURRENT LATITUDE IN RADIANS (1ST DATA PT) C******** FOR MODELS WITH DIFF LAT AT EACH PT, NEED TO C******** USE THE LAT OF ALL POINTS....CAREFUL..... C RHCLD - CLOUD-RH RELATIONS FROM MITCHELL+HAHN, C USING A.F. RTNEPH ANALYSES C ISTRAT - 0 OR 1:FOR DEFAULT OR 'RHCLD' TABLES C IN THE STRATIFORM CLOUD CALCULATION CTUNE C OUTPUT VARIABLES: C CLDARY - VERTICAL COLUMN ARRAY OF CLOUD FRACTION C PROFILE C CLD - CLD FRACTION IN 3 TYPES OF DOMAINS (L,M,H) C AND TOTAL IN 4TH LAYER C MTOP,MBOT - TOP, BOTTOM LAYERS OF CLOUDS (L,M,H) C C-------------------------------------------------------------------- C P A R A M E T E R 1 ( RD= 2.8705E+2 , RV= 4.6150E+2 , EPS=RD/RV, EPSM1=RD/RV-1.0, PI= 1 3.141593E+0 ) D I M E N S I O N 1 PS(IMX22), CV(IMX2), CVT(IMX2), CVB(IMX2) 2, SLMSK(IMX2),SI(KMX+1), SL (KMX) 3, T(IMX22,KMX), VVEL(IMX2,KMX), Q(IMX22,KMX) CTOT 4, CLD(IMX2,3), MTOP(IMX2,3), MBOT(IMX2,3) 4, CLD(IMX2,4), MTOP(IMX2,3), MBOT(IMX2,3) CYH945, CLDARY(IMX2,KMX), CLSTR(IMX2) 5, CLDARY(IMX2,KMX),XLATRD(IMX2) CTUNE C... RH-CLD RELATIONSHIPS FOR EACH POINT DIMENSION RHCLD(IMX2,NBIN,MCLD) CTUNE C C --- PTOPC(K,L): TOP PRESURE OF EACH CLD DOMAIN (K=1-4 ARE SFC,L,M,H; C L=1,2 ARE LOW-LAT (<45 DEGREE) AND POLE REGIONS) COMMON /COMCD1/ ROCP,PTOPC(4,2),CVTOP,VVCLD(2),CLAPSE 1, CRHRH,KLOWT,KLOWB,PSTRT 2, LLYR,LLLYR,CLAPKC,DCLPS,CLPSE C --- WORKSPACE --- L O G I C A L CYH941 BITX( 384 ), BITY( 384 ), BITZ( 384 ), BITW( 384 ), BIT1, BIT2 1 BITX( 384 ), BITY( 384 ), BITZ( 384 ), BIT1, BIT2 2, BITM( 384 ) D I M E N S I O N 1 RHRH ( 384 , 28 ), PRSLY( 384 , 28 ), DTHDP( 384 , 28 ) 2, THETA( 384 , 28 ), KCUT ( 384 ), KBASE( 384 ) 3, KBT1 ( 384 ), KTH1 ( 384 ), CL1 ( 384 ) 4, KBT2 ( 384 ), KTH2 ( 384 ), CL2 ( 384 ) 5, KCVB ( 384 ), KCVT ( 384 ), OMEG ( 384 ) CNOT 6, FACV ( 384 ,3), KSAVE( 384 ) 6, KSAVE( 384 ) 7, PTOP1( 384 ,4) CC E Q U I V A L E N C E CC 1 (KBT1, KCVB, THETA(1,1)), (KBT2, KCUT, THETA(1,2)) CC 2, (KTH1, KCVT, THETA(1,3)), (KTH2, THETA(1,4)) CC 3, (CL1 , THETA(1,5)), (CL2 , THETA(1,6)) CC 4, (CR1 , THETA(1,7)), (CR2 , THETA(1,8)) CC 5, (OMEG, THETA(1,9)), (KBASE, THETA(1,10)) CC 6, (XCRH1, THETA(1,11)), (XCRH2,FACV, THETA(1,12)) C===> BEGIN HERE ................................................ KDIM=KMX KDIMP=KMX+1 LEVM1=KMX-1 LEVM2=KMX-2 C... FIND TOP PRESSURE FOR EACH CLOUD DOMAIN DO 4 K=1,4 DO 4 I=1,IMX2 FAC = MAX (0.0 E 0, 4.0 E 0*ABS(XLATRD(I))/PI-1.0 E 0) PTOP1(I,K) = PTOPC(K,1) + (PTOPC(K,2)-PTOPC(K,1)) * FAC 4 CONTINUE C --- LOW CLOUD TOP SIGMA LEVEL, COMPUTED FOR EACH LAT CAUSE C DOMAIN DEFINITION CHANGES WITH LATITUDE... KLOW=KDIM CBBK DO 10 I=1,IMX2 CBBK SILOW = PTOP1(I,2) * 1.0 E -3 CBBK DO 6 K=1,KDIM CBBK KK=K CBBK IF (SI(KK) .LT. SILOW) GO TO 8 C 6 CONTINUE C 8 KLOW = MIN(KLOW,KK) C 10 CONTINUE DO 10 K=KDIM,1,-1 DO 10 I=1,IMX2 IF (SI(K) .LT. PTOP1(I,2) * 1.0 E -3) KLOW = MIN(KLOW,K) 10 CONTINUE C --- POTENTIAL TEMP AND LAYER RELATIVE HUMIDITY DO 40 K=1,KDIM DO 40 I=1,IMX2 CLDARY(I,K) = 0.0 E 0 PRSLY(I,K) = PS(I) * SL(K) * 10.0 E 0 EXNR = (PRSLY(I,K)*0.001 E 0) ** (-ROCP) THETA(I,K) = EXNR * T(I,K) ES = FPVS(T(I,K)) QS = EPS * ES / (SL(K)*PS(I) + EPSM1*ES) RHRH(I,K) = MAX (0.0 E 0, MIN (1.0 E 0, Q(I,K)/QS)) 40 CONTINUE C --- POTENTIAL TEMP LAPSE RATE DO 50 K=1,LEVM1 DO 50 I=1,IMX2 DTHDP(I,K) = (THETA(I,K+1) - THETA(I,K)) / 1 (PRSLY(I,K+1) - PRSLY(I,K)) 50 CONTINUE C ------------------------------------------------------------------ C FIND THE STRATOSPHERE CUT OFF LAYER FOR HIGH CLOUD. IT C IS ASSUMED TO BE ABOVE THE LAYER WITH DTHDP LESS THAN C -0.25 IN THE HIGH CLOUD DOMAIN (FROM LOOKING AT 1 CASE). C ------------------------------------------------------------------ DO 60 I=1,IMX2 KCUT(I) = LEVM2 60 CONTINUE DO 80 K=KLOW+1,LEVM2 BIT1 = .FALSE. DO 70 I=1,IMX2 IF (KCUT(I).EQ.LEVM2 .AND. PRSLY(I,K).LE.PTOP1(I,3) .AND. 1 DTHDP(I,K).LT.-0.25 E 0) THEN KCUT(I) = K END IF BIT1 = BIT1 .OR. KCUT(I).EQ.LEVM2 70 CONTINUE IF (.NOT. BIT1) GO TO 85 80 CONTINUE 85 CONTINUE C ------------------------------------------------------------------ IF (ISTRAT.LE.0) THEN C ------------------------------------------------------------------ C ....DEFAULT SCHEME ....TUNED FOR 28 LYRS BY Y-T HOU. CYH CALCULATE STRATIFORM CLOUD AND PUT INTO ARRAY 'CLDARY' CYH THE RELATIVE HUMIDITY CRITERIA ARE PRESET FOR EACH MODEL CYH SIGMA LEVEL, (1) FOR OCEAN POINTS, AND (2) FOR LAND POINTS. C ------------------------------------------------------------------ CKAC DO 130 K=3,LEVM2 DO 130 K=KLOWB,LEVM2 BIT1 = .FALSE. DO 90 I=1,IMX2 CYH.. BITX(I) = PRSLY(I,K).LE.PLOW .AND. K.LE.KCUT(I) BITX(I) = K.LE.KCUT(I) BIT1 = BIT1 .OR. BITX(I) 90 CONTINUE IF (.NOT. BIT1) GO TO 130 SPNT = MAX (0.6 E 0, MIN (0.85 E 0, 0.96 E 0-0.6 E 0*SL(K))) CR1SE1 = (0.41 E 0*SL(K) - 0.71 E 0)**2 + 0.52 E 0 CR1SL1 = 0.8 E 0 - 0.167 E 0*SL(K) DO 100 I=1,IMX2 CYH.. CR1 = CRH(K,1) CYH.. IF (SLMSK(I).EQ.1.0 E 0) CR1 = CRH(K,2) CYH XCRH1 = 0.67 * (RHMAX - CR1) IF (SLMSK(I).EQ.1.0 E 0) THEN CR1 = CR1SE1 ELSE CR1 = CR1SL1 END IF XCRH1 = SPNT * (RHMAX - CR1) CR2 = CR1 + XCRH1 XCRH2 = RHMAX - CR2 CL1(I) = MAX (0. E 0, (RHRH(I,K)-CR1)/XCRH1) ** 3 CYH CL1(I) = CL1(I)**4 IF (CL1(I).GT.1.0 E 0) 1 CL1(I) = 1. E 0 + SQRT((RHRH(I,K)-CR2)/XCRH2) 100 CONTINUE DO 120 I=1,IMX2 IF (BITX(I)) THEN CLDARY(I,K) = MIN (1.0 E 0, 0.5 E 0*CL1(I)) END IF 120 CONTINUE 130 CONTINUE C ------------------------------------------------------------------ C SPECIAL TREATMENT ON LOW CLOUDS C ------------------------------------------------------------------ DVVCLD = VVCLD(1) - VVCLD(2) RCLAP = 1.0 E 0 / (0.8 E 0 - CRHRH) DO 180 I=1,IMX2 KBASE(I) = 0 180 CONTINUE C DO 350 K=KLOWB,KLOWT C DO 190 I=1,IMX2 OMEG(I) = 10.0 E 0 * VVEL(I,K) CL1 (I) = 0.0 E 0 190 CONTINUE IF (IVVA .LE. 0) GO TO 250 C --- VERTICAL VELOCITY ADJUSTMENT ON LOW CLOUDS BIT1 = .FALSE. DO 210 I=1,IMX2 BITX(I) = PRSLY(I,K).GE.PTOP1(I,2) .AND. CLDARY(I,K).GT.0.0 E 10 BIT1 = BIT1 .OR. BITX(I) 210 CONTINUE IF (.NOT. BIT1) GO TO 250 DO 220 I=1,IMX2 IF (BITX(I)) THEN IF (OMEG(I).GE.VVCLD(1)) THEN CLDARY(I,K) = 0.0 E 0 ELSE IF(OMEG(I).GT.VVCLD(2)) THEN CR1 = (VVCLD(1) - OMEG(I)) / DVVCLD C CLDARY(I,K) = CLDARY(I,K) * CR1 CLDARY(I,K) = CLDARY(I,K) * SQRT(CR1) ENDIF ENDIF 220 CONTINUE C --- T INVERSION RELATED STRATUS CLOUDS 250 IF (INVR .LT. 1) GO TO 350 BIT1 = .FALSE. DO 260 I=1,IMX2 BITX(I) = PRSLY(I,K).GE.PSTRT .AND. SLMSK(I).LE.0.0 1 .AND. DTHDP(I,K).LE.CLAPSE CYH 2 .AND. OMEG (I).GT.0.0 BIT1 = BIT1 .OR. BITX(I) 260 CONTINUE IF (.NOT. BIT1) GO TO 350 DO 270 I=1,IMX2 IF ( KBASE(I).EQ.0 .AND. RHRH(I,K).GT.CRHRH .AND. BITX(I) ) 1 KBASE(I) = K 270 CONTINUE DO 300 I=1,IMX2 IF (KBASE(I).GT.0 .AND. BITX(I) .AND. CLDARY(I,K+1).LE.0.1 E - 11 1 .AND. CLDARY(I,K+2).LE.0.1 E -1) THEN CR1 = MIN (1.0 E 0, 1 MAX (0.0 E 0, 16.67 E 0*(CLAPSE-DTHDP(I,K)) )) IF(RHRH(I,KBASE(I)).LT.0.8 E 0) THEN CR1 = CR1 * (RHRH(I,KBASE(I))-CRHRH) * RCLAP ENDIF C --- FOR T INVERSION TYPE CLOUD, ADD FLAG VALUE OF 2.0 CLDARY(I,K) = MAX (CLDARY(I,K), CR1) + 2.0 E 0 ENDIF 300 CONTINUE 350 CONTINUE C ------------------------------------------------------------------ END IF C ------------------------------------------------------------------ IF (ISTRAT.GT.0) THEN CTUNE C ------------------------------------------------------------------ C CALCULATE STRATIFORM CLOUD AND PUT INTO ARRAY 'CLDARY' USING C THE CLOUD-REL.HUMIDITY RELATIONSHIP FROM TABLE LOOK-UP..WHERE C TABLES OBTAINED USING K.MITCHELL FREQUENCY DISTRIBUTION TUNING C (OBSERVATIONS ARE DAILY MEANS FROM US AF RTNEPH).....K.A.C. C TABLES CREATED WITHOUT LOWEST 10 PERCENT OF ATMOS.....K.A.C. C ------------------------------------------------------------------ C THIS LOOP TO RETRIEVE CLOUD FROM RH REWRITTEN 950113 -MI DO KLEV=KLOWB,LEVM2 DO I=1,IMX2 KBASE(I)=0 BITX(I)=.FALSE. ENDDO DO KC=MCLD,1,-1 DO I=1,IMX2 IF(PRSLY(I,KLEV).GE.PTOP1(I,KC+1)) KBASE(I)=KC ENDDO ENDDO NX=0 NHALF=(NBIN+1)/2 DO I=1,IMX2 IF(KBASE(I).LE.0.OR.KLEV.GT.KCUT(I)) THEN CLDARY(I,KLEV)=0. ELSEIF(RHRH(I,KLEV).LE.RHCLD(I,1,KBASE(I))) THEN CLDARY(I,KLEV)=0. ELSEIF(RHRH(I,KLEV).GE.RHCLD(I,NBIN,KBASE(I))) THEN CLDARY(I,KLEV)=1. ELSE BITX(I)=.TRUE. KSAVE(I)=NHALF NX=NX+1 ENDIF ENDDO DOWHILE(NX.GT.0) NHALF=(NHALF+1)/2 DO I=1,IMX2 IF(BITX(I)) THEN CRK=RHRH(I,KLEV) CR1=RHCLD(I,KSAVE(I),KBASE(I)) CR2=RHCLD(I,KSAVE(I)+1,KBASE(I)) IF(CRK.LE.CR1) THEN KSAVE(I)=MAX(KSAVE(I)-NHALF,1) ELSEIF(CRK.GT.CR2) THEN KSAVE(I)=MIN(KSAVE(I)+NHALF,NBIN-1) ELSE CLDARY(I,KLEV)=0.01*(KSAVE(I)+(CRK-CR1)/(CR2-CR1)) BITX(I)=.FALSE. NX=NX-1 ENDIF ENDIF ENDDO ENDDO ENDDO C.... CLEAN OUT NOT-SUSPECTED MARINE STRATUS REGIONS... C CAUSE TUNING PROCEDURE NOT CARRIED OUT DOWN TO LYR3 AND WE C GET TOO MUCH LO CLOUD IF WE DON T CLEAN IT OUT.. DO 831 I=1,IMX2 BITM(I) = .TRUE. 831 CONTINUE CKAC DO 833 K=3,LLYR DO 833 K=KLOWB,LLYR DO 832 I=1,IMX2 IF(BITM(I)) THEN BITM(I) = PRSLY(I,K).LT.PSTRT 1 .OR. SLMSK(I).GT.0.0 .OR. DTHDP(I,K).GT.CLAPKC.OR. CKC 2 CLDARY(I,K+1).GT.0.005 E 0.OR.CLDARY(I,K+2).GT.0.005 E 0 CKAC 2 RHRH (I,K+1).GT.0.80 E 0.OR.RHRH (I,K+2).GT.0.80 E 0 2 RHRH (I,K+1).GT.0.60 E 0.OR.RHRH (I,K+2).GT.0.60 E 0 KBASE(I) = K ENDIF 832 CONTINUE 833 CONTINUE DO 835 K=1,LLYR DO 834 I=1,IMX2 IF(BITM(I)) CLDARY(I,K) = 0.0 E 0 834 CONTINUE 835 CONTINUE C ------------------------------------------------------------------ C SPECIAL TREATMENT ON LOW CLOUDS C ------------------------------------------------------------------ DVVCLD = VVCLD(1) - VVCLD(2) C CKAC DO 950 K=3,KLOW DO 950 K=KLOWB,KLOW C DO 904 I=1,IMX2 OMEG(I) = 10.0 E 0 * VVEL(I,K) CL1 (I) = 0.0 E 0 904 CONTINUE CYH94 IF (IVVA .LT. 1) GO TO 920 IF (IVVA .LE. 0) GO TO 920 C --- VERTICAL VELOCITY ADJUSTMENT ON LOW CLOUDS BIT1 = .FALSE. DO 906 I=1,IMX2 BITX(I) = PRSLY(I,K).GE.PTOP1(I,2) .AND. CLDARY(I,K).GT.0.0 E 10 BIT1 = BIT1 .OR. BITX(I) 906 CONTINUE IF (.NOT. BIT1) GO TO 920 IF(K.GT.LLYR) THEN DO 910 I=1,IMX2 IF (BITX(I)) THEN IF(OMEG(I).GE.VVCLD(1)) THEN CLDARY(I,K) = 0.0 E 0 ELSE IF(OMEG(I).GT.VVCLD(2)) THEN CR1 = (VVCLD(1) - OMEG(I)) / DVVCLD C CLDARY(I,K) = CLDARY(I,K) * CR1 CLDARY(I,K) = CLDARY(I,K) * SQRT(CR1) ENDIF ENDIF 910 CONTINUE ELSE DO 915 I=1,IMX2 C.... NO VVEL FILTER FOR MARINE STRATUS REGION IF (BITM(I)) THEN IF (BITX(I)) THEN IF(OMEG(I).GE.VVCLD(1)) THEN CLDARY(I,K) = 0.0 E 0 ELSE IF(OMEG(I).GT.VVCLD(2)) THEN CR1 = (VVCLD(1) - OMEG(I)) / DVVCLD C CLDARY(I,K) = CLDARY(I,K) * CR1 CLDARY(I,K) = CLDARY(I,K) * SQRT(CR1) ENDIF ENDIF ENDIF 915 CONTINUE ENDIF C --- T INVERSION RELATED STRATUS CLOUDS 920 IF (INVR .LT. 1) GO TO 950 IF (K.GT.LLYR) GO TO 950 BIT1 = .TRUE. DO 930 I=1,IMX2 BIT1 = BIT1 .AND. BITM(I) 930 CONTINUE IF (BIT1) GO TO 950 DO 940 I=1,IMX2 IF (.NOT.BITM(I)) THEN IF (DTHDP(I,KBASE(I)).GT.CLPSE) THEN C--- SMOOTH TRANSITION FOR CLOUD WHEN DTHDP BETWEEN C CLAPSE AND CLAPSE+DCLPS (-0.05 AND -0.06) CFILTR = 1.0 E 0 - ((CLPSE - DTHDP(I,KBASE(I))) / DCLPS) CLDARY(I,K) = CLDARY(I,K)*CFILTR END IF C --- FOR T INVERSION TYPE CLOUD, ADD FLAG VALUE OF 2.0 CLDARY(I,K) = CLDARY(I,K)+2.0 E 0 END IF 940 CONTINUE 950 CONTINUE C ------------------------------------------------------------------ END IF CTUNE C ------------------------------------------------------------------ C ADD CONVECTIVE CLOUD INTO 'CLDARY', NO MERGE AT THIS POINT.. C TWO TYPES OF CLOUDS ARE SEPARATED BY A FACTOR OF 1.0E+4 C ------------------------------------------------------------------ 360 BIT1 = .FALSE. CNOT DO 370 L=1,3 CNOT DO 370 I=1,IMX2 CNOT FACV(I,L) = 1.0 E 0 C370 CONTINUE DO 380 I=1,IMX2 BITX(I) = CV(I).GT.0.0 E 0 .AND. CVT(I).GE.CVB(I) BIT1 = BIT1 .OR. BITX(I) 380 CONTINUE IF (.NOT. BIT1) GO TO 550 DO 390 I=1,IMX2 IF (BITX(I)) THEN KCVB(I) = NINT(CVB(I)) KCVT(I) = MIN(LEVM2, NINT(CVT(I))) ELSE KCVB(I) = 1 KCVT(I) = 1 END IF 390 CONTINUE CKAC DO 450 K=KLOWB,LEVM2 DO 450 K=KLOWB,LEVM2 BIT2 = .FALSE. DO 400 I=1,IMX2 BITY(I) = BITX(I) .AND. KCVB(I).LE.K .AND. KCVT(I).GE.K BIT2 = BIT2 .OR. BITY(I) 400 CONTINUE IF (.NOT. BIT2) GO TO 450 DO 420 I=1,IMX2 IF (BITY(I)) CLDARY(I,K) = CLDARY(I,K) 1 + 10.0 E 0 * AINT(1.0 E 3 * CV(I)) 420 CONTINUE 450 CONTINUE C IF MEAN CVT LAYER HIGHER THAN 400MB ADD ANVIL CIRRUS BIT2 = .FALSE. DO 460 I=1,IMX2 BITZ(I) = BITX(I) .AND. PRSLY(I,KCVT(I)).LE.CVTOP BIT2 = BIT2 .OR. BITZ(I) 460 CONTINUE IF (.NOT. BIT2) GO TO 500 DO 480 I=1,IMX2 IF (BITZ(I)) THEN CKAC KK = KCVT(I) + 1 KK = KCVT(I) CR1 = MAX (0.0 E 0, MIN (1.0 E 0, 2.0 E 0*(CV(I)-0.3 E 0))) C.... GET STRATUS BACK BEFORE DOING ANVIL CALCULATION CR2 = MOD(CLDARY(I,KK),10. E 0) CLDARY(I,KK) = CR2 + 10.0 E 0*AINT(1.0 E 3*CR1) CKAC CLDARY(I,KK) = CLDARY(I,KK) + 10.0 E 0*AINT(1.0 E 3*CR1) END IF 480 CONTINUE C ------------------------------------------------------------------- C SEPARATE CLOUDS INTO 3 PRESSURE DOMAINS (L,M,H). WITHIN EACH C OF THE DOMAINS, ASSUME SEPARATED CLOUD LAYERS ARE RANDOMLY C OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED. C VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY C THE THICKEST CONTINUING CLOUD LAYERS IN THE DOMAIN. CNOT DEEP CONVECTIVE CLOUD SPAN MORE THAN 1 DOMAIN WILL BE MULTIPLIED CNOT BY A FACTOR FOR EACH OF THE DOMAINS. C ------------------------------------------------------------------- 500 CONTINUE CNOT DO 520 L=1,2 CNOT DO 520 I=1,IMX2 CNOT IF (BITX(I) .AND. PRSLY(I,KCVB(I)).GE.PTOP1(I,L+1) CNOT 1 .AND. PRSLY(I,KCVT(I)).LT.PTOP1(I,L+1)) THEN CYH94 FACV(I,L) = MAX (0.30 E 0, 0.80 E 0*FACV(I,L)) CNOT FACV(I,L) = MAX (0.35 E 0, 0.80 E 0*FACV(I,L)) CYH94 FACV(I,L+1) = 0.30 E 0 CNOT FACV(I,L+1) = 0.35 E 0 CNOT END IF C520 CONTINUE 550 CONTINUE C DO 552 I=1,64,10 C WRITE(6,551) I,(CLDARY(I,K),K=1,KDIM) C551 FORMAT(' IN CLDNEW: I=',I3,' CLDARY(I,K)=',8E10.2/10X,10E10.2) C552 CONTINUE CYH94 FOVP = 1.0 E 0 / ANINT(FLOAT(KDIM) / 9.0 E 0) C --- LOOP OVER 3 CLOUD DOMAINS (L,M,H) DO 750 L=1,3 C DO 580 I=1,IMX2 CLD (I,L) = 0.0 E 0 MTOP(I,L) = 1 MBOT(I,L) = 1 CL1 (I) = 0.0 E 0 CL2 (I) = 0.0 E 0 KBT1(I) = 1 KBT2(I) = 1 KTH1(I) = 0 KTH2(I) = 0 580 CONTINUE C DO 700 K=2,LEVM2 BIT1 = .FALSE. DO 600 I=1,IMX2 BITX(I) = (PRSLY(I,K).GE.PTOP1(I,L+1)) .AND. 1 (PRSLY(I,K).LT.PTOP1(I,L)) .AND. (CLDARY(I,K).GT.0.0 E 0) BIT1 = BIT1 .OR. BITX(I) 600 CONTINUE IF (.NOT. BIT1) GO TO 700 DO 630 I=1,IMX2 CR1 = MOD(CLDARY(I,K), 2.0 E 0) CR2 = FLOAT(INT(CLDARY(I,K)) / 10) * 1.0 E -3 CNOT CR3 = (CR1 + CR2 - CR1*CR2) * FACV(I,L) CNOT CR3 = (CR1 + CR2 - CR1*CR2) IF (BITX(I)) THEN IF(KTH2(I).LE.0) THEN C --- KTH2 LE 0 : 1ST CLD LAYER. KBT2(I) = K KTH2(I) = 1 ELSE C --- KTH2 GT 0 : CONSECUTIVE CLD LAYER. KTH2(I) = KTH2(I) + 1 ENDIF CNOT CL2 (I) = MAX (CL2(I), CR3) C --- PHYSICAL CLOUD AS SEEN BY RADIATION..CONV TAKES PRECEDENCE C --- EXCEPT ANVIL CIRRUS NOT RANDOM OVERLAPPED WITH CV TOWER AS C ... IN RADIATION CODE(SO HI MAY BE SLIGHT UNDERESTIMATE).... IF (CR2.GT.0.0 E 0) THEN CL2 (I) = MAX (CL2(I), CR2) ELSE CL2 (I) = MAX (CL2(I), CR1) END IF ENDIF 630 CONTINUE BIT2 = .FALSE. C.... BITY=TRUE IF NEXT LYR=CLEAR OR WE CHANGE CLOUD DOMAINS.. DO 640 I=1,IMX2 BITY(I) = BITX(I) .AND. (CLDARY(I,K+1).LE.0.0 E 0 1 .OR. PRSLY(I,K+1).LT.PTOP1(I,L+1) ) BIT2 = BIT2 .OR. BITY(I) 640 CONTINUE IF (.NOT. BIT2) GO TO 700 C --- AT THE DOMAIN BOUNDARY OR SEPARATED CLD LYRS, RANDOM OVERLAP. C CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD C LAYER IN THAT DOMAIN DO 650 I=1,IMX2 IF (BITY(I)) THEN IF (CL1(I).GT.0.0 E 0) THEN KBT1(I) = INT( (CL1(I)*KBT1(I) + CL2(I)*KBT2(I)) 1 / (CL1(I) + CL2(I)) ) KTH1(I) = NINT( (CL1(I)*KTH1(I) + CL2(I)*KTH2(I)) 1 / (CL1(I) + CL2(I)) ) + 1 CL1 (I) = CL1(I) + CL2(I) - CL1(I)*CL2(I) ELSE KBT1(I) = KBT2(I) KTH1(I) = KTH2(I) CL1 (I) = CL2 (I) ENDIF KBT2(I) = 1 KTH2(I) = 0 CL2 (I) = 0.0 E 0 ENDIF 650 CONTINUE 700 CONTINUE C --- FINISH ONE DOMAIN, SAVE EFFECTIVE CLOUDS DO 720 I=1,IMX2 CLD(I,L) = CL1(I) MTOP(I,L) = MAX(KBT1(I), KBT1(I)+KTH1(I)-1) MBOT(I,L) = KBT1(I) 720 CONTINUE 750 CONTINUE C.... CALCULATE TOTAL CLOUD FROM THE MULTI-LYR CLOUD ARRAY C .......IN A MANNER AS SEEN BY THE RADIATION CODE........ C WHERE, MAX OVERLAP IS USED FOR VERTICALLY ADJACENT CLOUD LAYERS C .. A CLEAR LAYER SEPARATES TWO CONTIGUOUSLY LAYERED CLOUD TYPES. C WHERE, FOR CONVECTION ANY ANVIL IS CONSIDERED A SEPARATE C RANDOMLY OVERLAPPED CLOUD.. C ILOW=0,1 IF NO,YES PRECEEDING MODEL LAYER WAS CLOUDY.. C CLOW CONTAINS THE CLOUDINESS OF PRECEEDING SEPARATE LAYERED CLD DO 780 I=1,IMX2 CLD(I,4) = 0. E 0 ICVEC = 0 ILOW = 0 CLOW = 0. E 0 DO 780 K=1,KDIM CCLDY = MOD(CLDARY(I,K), 2.0 E 0) CCVEC = FLOAT(INT(CLDARY(I,K)) / 10) * 1.0 E -3 IF (CCVEC.GT.0. E 0) THEN CCLDY = CCVEC ICVEC = 1 END IF IF (CCLDY.GT.0. E 0) THEN IF (ILOW.EQ.0) THEN CLOW = CCLDY ILOW = 1 ELSE IF (ICVEC.GT.0) THEN IF (CCLDY.NE.CLOW) THEN C... IF CONVECTIVE AND AN ADJACENT LYR=STRATIFORM (IE CCLDY CHANGES), C. THEN RANDOM OVERLAP THE PRECEEDING CLOUD TOWER... CLD(I,4) = CLD(I,4) + (1.-CLD(I,4))*CLOW CLOW = CCLDY END IF ELSE C... MAX OVERLAP FOR NON CONVECTIVE ADJACENT CLD LAYERS... CLOW = MAX(CCLDY,CLOW) END IF END IF ELSE IF (ILOW.EQ.1) THEN C... IF THIS IS FIRST CLEAR LAYER IN A GAP BETWIXT CLDLYRS, THEN C. RANDOM OVERLAP THE PRECEEDING CLOUDS WITH THE ONES BELOW.. CLD(I,4) = CLD(I,4) + (1.-CLD(I,4))*CLOW ILOW = 0 END IF END IF 780 CONTINUE RETURN END SUBROUTINE OMEGAS(IMX2,IMX22,KMX, 1 DPHI,DLAM,CG,UG,VG,DG,DEL,RCL,VVEL,PS,SL) CFPP$ NOCONCUR R C.... CODE LIFTED FROM POST (MCP1840) JUN 88--COMPUTES VVEL (CB/SEC) C.... INPUT PS IN CB,OUTPUT VVEL IN CB/SEC C.... DO LOOPS ALTERED FOR BETTER VECTORIZATION POSSIBILITIES..K.A.C. DIMENSION DPHI(IMX22),DLAM(IMX22), 1 CG(IMX2,KMX),UG(IMX22,KMX),VG(IMX22,KMX), 2 DG(IMX22,KMX),DEL(KMX),PS(IMX22),SL(KMX) C... VVEL CONTAINS OMEGA IN LAYERS ON RETURN FROM SUBROUTINE... DIMENSION VVEL(IMX2,KMX) C LOCAL ARRAY DIMENSION DB( 384 , 28 ),CB( 384 , 28 ),DOT( 384 , 28 +1) NX =IMX2 NXS=IMX22 NZ =KMX DO 1 K=1,NZ+1 DO 1 LO=1,NX DOT(LO,K) = 0. E 0 1 CONTINUE C... COMPUTE C=V(TRUE)*DEL(LN(PS)).DIVIDE BY COS FOR DEL COS FOR V DO 3 LO=1,NX DPHI(LO)=DPHI(LO)*RCL DLAM(LO)=DLAM(LO)*RCL 3 CONTINUE DO 5 LE=1,NZ DO 4 LO=1,NX CG(LO,LE)=UG(LO,LE)*DLAM(LO)+VG(LO,LE)*DPHI(LO) 4 CONTINUE 5 CONTINUE DO 10 LO=1,NX DB(LO,1)=DEL(1)*DG(LO,1) CB(LO,1)=DEL(1)*CG(LO,1) 10 CONTINUE DO 6 LE=1,NZ-1 DO 6 LO=1,NX DB(LO,LE+1)=DB(LO,LE)+DEL(LE+1)*DG(LO,LE+1) CB(LO,LE+1)=CB(LO,LE)+DEL(LE+1)*CG(LO,LE+1) 6 CONTINUE C... SIGMA DOT COMPUTED ONLY AT INTERIOR INTERFACES DO 7 K=1,NZ-1 DO 7 LO=1,NX DOT(LO,K+1)=DOT(LO,K)+DEL(K) 1 *(DB(LO,NZ)+CB(LO,NZ)-DG(LO,K)-CG(LO,K)) 7 CONTINUE DO 8 K=1,NZ DO 8 LO=1,NX VVEL(LO,K)= SL(K)*(CG(LO,K)-CB(LO,NZ)-DB(LO,NZ))- 1 0.5*(DOT(LO,K+1)+DOT(LO,K)) VVEL(LO,K)=VVEL(LO,K)*PS(LO) CCC VVEL(LO,K)=VVEL(LO,K)*PS(LO)*10. 8 CONTINUE RETURN END SUBROUTINE CLDIAG(AVECLA,CLDLA,AVECLB,CLDLB,CLD,CLDARY) CFPP$ NOCONCUR R PARAMETER (IMX2= 384 ,KDIM= 28 ) PARAMETER (IMX2H=IMX2/2) DIMENSION AVECLA(KDIM),CLDLA(4) DIMENSION AVECLB(KDIM),CLDLB(4) DIMENSION CLDARY(IMX2,KDIM),CLDSUM(IMX2,KDIM) DIMENSION CLD(IMX2,4) DATA NUMPTS / IMX2H / C... UNPACK CLDAMT AND CONV CLDAMT FROM CLDARY..(STRATUS IS +2) C. RADIATION SEES STRATIFORM OR CONVECTIVE...NOT MERGED..... C. SO CLDSUM REFLECTS THIS BELOW C... NOTE:CLDARY 2-4 DIGITS TO LEFT OF DECIMAL=CV CLOUD C. CLDARY 1 DIGIT TO LEFT OF DECIMAL+FRACTIONAL PART=STRAT CLD C. THOUGH ANVIL CI IS CONSIDERED STRATIFORM DO 10 K=1,KDIM DO 10 I=1,IMX2 CSTLYR = MOD(CLDARY(I,K),2. E 0) CST = MOD(CLDARY(I,K),10. E 0) CCVLYR = 1. E -4 * (CLDARY(I,K)-CST) CLDSUM(I,K) = CSTLYR IF (CCVLYR.GT.0. E 0) CLDSUM(I,K) = CCVLYR 10 CONTINUE DO 20 K=1,KDIM AVECLA(K) = 0. E 0 AVECLB(K) = 0. E 0 20 CONTINUE DO 30 K=1,4 CLDLA(K) = 0. E 0 CLDLB(K) = 0. E 0 30 CONTINUE DO 40 K=1,KDIM DO 40 I=1,IMX2H AVECLA(K) = AVECLA(K) + CLDSUM(I,K) AVECLB(K) = AVECLB(K) + CLDSUM(I+IMX2H,K) 40 CONTINUE DO 50 K=1,4 DO 50 I=1,IMX2H CLDLA(K) = CLDLA(K) + CLD(I,K) CLDLB(K) = CLDLB(K) + CLD(I+IMX2H,K) 50 CONTINUE DO 60 K=1,KDIM AVECLA(K) = AVECLA(K) / NUMPTS AVECLB(K) = AVECLB(K) / NUMPTS 60 CONTINUE DO 70 K=1,4 CLDLA(K) = CLDLA(K) / NUMPTS CLDLB(K) = CLDLB(K) / NUMPTS 70 CONTINUE RETURN END SUBROUTINE CVDIAG(AVEN,AVES,CV,CVT,CVB) DIMENSION CV( 384 ),CVT( 384 ),CVB( 384 ) DIMENSION AVEN(3),AVES(3) NPTNOR=0 NPTSOU=0 DO 10 K=1,3 AVEN(K)=0. E 0 AVES(K)=0. E 0 10 CONTINUE DO 2 I=1, 192 AVEN(1)=AVEN(1)+CV(I) AVES(1)=AVES(1)+CV(I+ 192 ) IF(CV(I).LE.0. E 0) GO TO 1 AVEN(2)=AVEN(2)+CVT(I) AVEN(3)=AVEN(3)+CVB(I) NPTNOR = NPTNOR + 1 1 IF(CV(I+ 192 ).LE.0. E 0) GO TO 2 AVES(2)=AVES(2)+CVT(I+ 192 ) AVES(3)=AVES(3)+CVB(I+ 192 ) NPTSOU = NPTSOU + 1 2 CONTINUE AVEN(1)=AVEN(1)/ 192 AVES(1)=AVES(1)/ 192 IF(NPTNOR.GT.0) THEN AVEN(2)=AVEN(2)/NPTNOR AVEN(3)=AVEN(3)/NPTNOR ENDIF IF(NPTSOU.GT.0) THEN AVES(2)=AVES(2)/NPTSOU AVES(3)=AVES(3)/NPTSOU ENDIF RETURN END SUBROUTINE PROFZL(Y,YAV,COLRAD,FHOUR,LEV,LPRT) PARAMETER (IDIM= 192 ,JDIM= 94 ,KDIM= 28 ,JDIM2=JDIM/2) C... PROGRAM TO TAKE A HEIGHT-LATITUDE ARRAY, Y(K,LA), C AND PRODUCE 18 APPROX EQUI-DISTANCE LAT BELT AVE OVER GLOBE C... ALSO COMPUTE WEIGHTED GLOBAL MEANS OF CLOUDS (IPRT=3) DIMENSION Y(LEV,JDIM),YAV(LEV,18),COLRAD(JDIM2) DIMENSION GLOBL(9,KDIM) CHARACTER*44 LTITLE(5) CHARACTER*20 KTITLE DATA NLAT/18/, JJ/JDIM2/ DATA LTITLE/' LAT MEAN LYR RADI8IVE HEAT(SW HAS TAUDA=1) ', 1 ' LATITUDE MEAN CLD FRACTION IN MODEL LAYERS ', 2 ' LATITUDE MEAN LOW(K=1),MID,HI,TOTAL CLDFRAC', 3 ' LATITUDE MEAN R.H.FRACTION IN MODEL LAYERS ', 4 ' LATITUDE MEAN CONVEC CLD FRAC,TOP,BOT '/ DATA KTITLE/'OPNL-T80-MODEL CLD '/ COMMON /PRFSAV/ LATLONP,MLATLON,RLAT(JDIM),WGT(JDIM),IB(18),IE(18) KK = LEV IF (LATLONP.GT.0) GO TO 5 C... COMPUTE BEGIN AND END LATITUDES FOR EACH OF THE 18 BELTS LATLONP = 10 IB(1) = 1 JDF = JDIM/18 LFTOVR = JDIM - JDF*18 IADD = -1 IF (LFTOVR.GT.0) IADD = 18./LFTOVR IE(1) = IB(1) + JDF - 1 LD = 1 IL = 0 IF (IADD.NE.1) GO TO 1 IE(1) = IE(1) + 1 LD = 0 IL = IL + 1 1 DO 2 L=2,18 IB(L) = IE(L-1) + 1 IE(L) = IB(L) + JDF - 1 LD = LD + 1 IF (LD.NE.IADD) GO TO 2 IF (IL.GE.LFTOVR) GO TO 2 IE(L) = IE(L) + 1 LD = 0 IL = IL + 1 2 CONTINUE 5 CONTINUE DO 10 K = 1,KK DO 20 LL = 1,NLAT YAV(K,LL)=0. E 0 JB = IB(LL) JE = IE(LL) DO 30 LA = JB,JE YAV(K,LL) =YAV(K,LL)+Y(K,LA) 30 CONTINUE YPTS = JE - JB + 1 YAV(K,LL) = YAV(K,LL) / YPTS 20 CONTINUE 10 CONTINUE CALL PRNTLL(YAV,FHOUR,LTITLE(LPRT),KK) C... COMPUTE AREA WGTD GLOBAL MEANS.. IF(LPRT.EQ.3) 1 CALL GLOBLM(Y,GLOBL,RLAT,WGT,KK,JDIM,COLRAD,KTITLE,FHOUR) RETURN END SUBROUTINE GLOBLM(Y,GLOBL,RLAT,WGT,KD,LD,COLRAD,LTITL,FHOUR) C... COMPUTE AREA WEIGHTED MEANS - GLOBAL,HEMISPHERIC,ETCCCC C.. INPUT: C Y = LATITUDINAL MEANS - LD LATITUDES,KD LAYERS.. C COLRAD = CO-LATIUDES IN RADIANS (N.H.) C LTITL = PRINTING LABEL (CHARACTER*20) C FHOUR = FORECAST HOUR C.. OUTPUT: PRINTED VALUES (FT06F001) C GLOBL(1,KD)=GLOBAL MEAN C GLOBL(2,KD)=NORTHERN HEMISPHERE MEAN C GLOBL(3,KD)=NORTHERN HEMISPHERE POLAR (90-60DEG) MEAN C GLOBL(4,KD)=NORTHERN HEMISPHERE MIDLAT(60-30DEG) MEAN C GLOBL(5,KD)=NORTHERN HEMISPHERE TROPIC(30-0 DEG) MEAN C GLOBL(6,KD)=SOUTHERN HEMISPHERE MEAN C GLOBL(7,KD)=SOUTHERN HEMISPHERE POLAR (90-60DEG) MEAN C GLOBL(8,KD)=SOUTHERN HEMISPHERE MIDLAT(60-30DEG) MEAN C GLOBL(9,KD)=SOUTHERN HEMISPHERE TROPIC(30-0 DEG) MEAN DIMENSION Y(KD,LD),COLRAD(LD) CHARACTER*20 LTITL DIMENSION GLOBL(9,KD),RLAT(LD),WGT(LD) DIMENSION GLOBX(9,100) COMMON /GLBSAV/ LATLONG,LLATLON,J30,J60,WTSUM(5) JJ = LD / 2 KK = KD IF (LATLONG.GT.0) GO TO 30 C... COMPUTE AREA WGTS AND LATITUDES JUST POLEWARD OF 60DEG (J60) C AND JUST POLEWARD OF 30DEG (J30) LATLONG = 10 RAD60 = 3.141593E+0 / 3. E 0 RAD30 = 3.141593E+0 / 6. E 0 C... LATITUDE IN RADIANS DO 5 J=1,JJ RLAT(J) = 3.141593E+0 / 2. E 0 - COLRAD(J) 5 CONTINUE DO 10 J=1,JJ IF(RLAT(J).LT.RAD60) GO TO 15 J60 = J 10 CONTINUE GO TO 200 15 DO 20 J=1,JJ IF(RLAT(J).LT.RAD30) GO TO 25 J30 = J 20 CONTINUE GO TO 205 25 DO 26 N=1,5 WTSUM(N) = 0. 26 CONTINUE RLATS = 0.5 E 0 * (RLAT(1)+RLAT(2)) WGT(1) = 1. - SIN(RLATS) RLATN = 0.5 E 0 * (RLAT(JJ)+RLAT(JJ-1)) WGT(JJ) = SIN(RLATN) DO 27 LA=2,JJ-1 RLATN = 0.5 E 0 * (RLAT(LA)+RLAT(LA-1)) RLATS = 0.5 E 0 * (RLAT(LA)+RLAT(LA+1)) WGT(LA) = SIN(RLATN) - SIN(RLATS) 27 CONTINUE PRINT 9,JJ,J60,J30 9 FORMAT(1H ,' JJ=',I4,' J60=',I4,' J30=',I4) DO 28 LA=1,JJ C.. GLOBAL AREA WTSUM(1) = WTSUM(1) + 2. E 0 * WGT(LA) C.. HEMISPHERIC AREA WTSUM(2) = WTSUM(2) + WGT(LA) C.. LATITUDE STRIP AREAS IF (LA.GT.J60) GO TO 31 WTSUM(3) = WTSUM(3) + WGT(LA) GO TO 28 31 IF (LA.GT.J30) GO TO 32 WTSUM(4) = WTSUM(4) + WGT(LA) GO TO 28 32 WTSUM(5) = WTSUM(5) + WGT(LA) 28 CONTINUE C... 30 CONTINUE C... DO 35 K = 1,KK DO 35 J = 1,9 GLOBL(J,K) = 0. E 0 35 CONTINUE DO 75 LA=1,JJ DO 45 K=1,KK GLOBL(2,K) = GLOBL(2,K) + WGT(LA)*Y(K,LA) GLOBL(6,K) = GLOBL(6,K) + WGT(LA)*Y(K,LD+1-LA) GLOBL(1,K) = GLOBL(2,K) + GLOBL(6,K) 45 CONTINUE IF (LA.GT.J60) GO TO 55 DO 50 K=1,KK GLOBL(3,K) = GLOBL(3,K) + WGT(LA)*Y(K,LA) GLOBL(7,K) = GLOBL(7,K) + WGT(LA)*Y(K,LD+1-LA) 50 CONTINUE GO TO 75 55 IF (LA.GT.J30) GO TO 65 DO 60 K=1,KK GLOBL(4,K) = GLOBL(4,K) + WGT(LA)*Y(K,LA) GLOBL(8,K) = GLOBL(8,K) + WGT(LA)*Y(K,LD+1-LA) 60 CONTINUE GO TO 75 65 DO 70 K=1,KK GLOBL(5,K) = GLOBL(5,K) + WGT(LA)*Y(K,LA) GLOBL(9,K) = GLOBL(9,K) + WGT(LA)*Y(K,LD+1-LA) 70 CONTINUE 75 CONTINUE DO 85 K=1,KK GLOBX(1,K) = GLOBL(1,K) / WTSUM(1) GLOBL(1,K) = GLOBL(1,K) / WTSUM(1) DO 80 I=2,5 GLOBX(I,K) = GLOBL(I,K) / WTSUM(1) GLOBX(I+4,K) = GLOBL(I+4,K) / WTSUM(1) GLOBL(I,K) = GLOBL(I,K) / WTSUM(I) GLOBL(I+4,K) = GLOBL(I+4,K) / WTSUM(I) 80 CONTINUE 85 CONTINUE PRINT 92,LTITL,FHOUR PRINT 93 PRINT 97 PRINT 95 DO 90 KEN=1,KK K = KK+1-KEN PRINT 100,K,(GLOBL(I,K),I=1,9) 90 CONTINUE PRINT 98 PRINT 95 DO 11 KEN=1,KK K = KK+1-KEN PRINT 100,K,(GLOBX(I,K),I=1,9) 11 CONTINUE RETURN 92 FORMAT (1H ,10X,' AREA WEIGHTED MEANS',2X,A20,' FCSTHR=',F6.1) 93 FORMAT (1H ,11X,' -------------------------------------') 95 FORMAT (1H ,4X,'K',5X,'GLOBAL',4X,'N HEMI',4X,'NHPOLR',4X, 1 'NHMIDL',4X,'NHTRPC',4X,'S HEMI',4X, 2 'SHPOLR',4X,'SHMIDL',4X,'SHTRPC') 97 FORMAT (1H ,15X,'====> WEIGHTED RELATIVE TO SPECIFIED REGION') 98 FORMAT (1H ,15X,'====> WEIGHTED RELATIVE TO ENTIRE GLOBE') 100 FORMAT (1H ,I5,9F10.3) 200 PRINT 201 STOP 205 PRINT 206 STOP 201 FORMAT (1H ,' STOP -- CAN T FIND J60') 206 FORMAT (1H ,' STOP -- CAN T FIND J30') END SUBROUTINE PRNTLL(Y,THOUR,ITITL,KMAX) DIMENSION Y(KMAX,18) CHARACTER*44 ITITL PRINT 930 PRINT 910,THOUR,ITITL DO 10 K=1,KMAX KK = KMAX +1 -K PRINT 920,KK,(Y(KK,LAT), LAT = 1,18) 10 CONTINUE PRINT 930 910 FORMAT(/,' FCST HOUR=',F4.0,' EQUI-DIST LAT BELT AVE=N.POLE TO', 1 ' S.POLE ',A44) 920 FORMAT(I3,2X,18F7.3) C930 FORMAT(1H ,128(1H- ) ) 930 FORMAT('========') RETURN END SUBROUTINE CLINTF(CVIN,IIN,JTWIDL,JIN, 1 CVOUT,IOUT,JPOUT,JOUT,LEVS, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 3 XX,WGT,SUM,NN, 4 LTWIDL,LATRD1,LATINB) C-- ***************************************************************** C * CODE BILINEARLY INTERPOLATES CLD AMT BETWEEN GAUSSIAN GRIDS--* C * CLONE OF CVINTF FOR INTERPOLATION..TOPS,BASES NOT DONE * C- * J = 1 IS JUST BELO N.POLE, I = 1 IS GREENWICH (THEN GO EAST).* C * IIN,JIN ARE I,J DIMENSIONS OF INPUT GRID--IOUT,JOUT FOR OUTPUT* C * JIN2,JOUT2=JIN/2,JOUT/2 * C * --K.CAMPANA - SEPT 1994 * C-- ***************************************************************** DIMENSION CVIN(IIN,LEVS,JTWIDL) DIMENSION CVOUT(IOUT,LEVS,JPOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION INSLAT(JOUT),WGTLAT(JOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4),SUM(IOUT,2) DIMENSION NN(IOUT) III = IIN JBB = JTWIDL JJJ = JIN IIIOUT = IOUT LBB = LTWIDL LR1 = LATRD1 DO 50 LATOUT=1,JPOUT LAT=LATOUT+LATINB-1 CCC PRINT 100,LAT,XLAT C===> IF OUTPUT LAT IS POLEWARD OF INPUT LAT=1 ,THEN SIMPL AVERAGE C (SMALL REGION AND CLD AMT WOULDN T EXTRAPOLATE WELL) CALL CLDIN(III,JBB,JJJ,IIIOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT(LAT),WGTLAT(LAT), 2 CVIN,CVOUT(1,1,LATOUT),LEVS, 3 XX,WGT,SUM,NN,LBB,LR1) 50 CONTINUE CK100 FORMAT(1H ,' ROW =',I5,' LAT =',E15.5) RETURN END SUBROUTINE CLDIN(IIN,JTWIDL,JIN,IOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 2 CV,CAMT,LEVS, 3 XX,WGT,SUM,NN,LTWIDL,LATRD1) DIMENSION CV(IIN,LEVS,JTWIDL) DIMENSION CAMT(IOUT,LEVS) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4),SUM(IOUT,2) DIMENSION NN(IOUT) C... CLONE OF CINTP WITHOUT DOING CLD TOPS AND BASES..... C SIMPL LINEAR INTERPOLATION OF CLDAMT, UNLESS ONLY 1,2 OF THE C SURROUNDING PTS HAS CL. THEN,IF OUTPUT GRIDPT NOT CLOSE ENUF C DO NOT INTERPOLATE TO IT(PREVENTS SPREADING OF CLDS).. C FOR 1 PT CLOUD AMT -INTRP WGT GE (.7)**2 ... C FOR 2 PT CLOUD AMT -SUM OF INTRP WGT GE .45... C .45 USED RATHER THAN .5 TO GIVE BETTER RESULT FOR C DIAGONALLY OPPOSED PTS... C--- NHSH = 1,-1 FOR NORTHERN,SOUTHERN HEMISPHERE C HERE INSTEAD OF AN EXTRAPOLATION,JUST DO A SIMPLE MEAN.... C C--- POLAR REGIONS,NO EXTRAP (INSLAT < 0) IF (INSLAT.LT.0) GO TO 600 C INTH = MOD(LTWIDL + INSLAT - LATRD1 - 1,JTWIDL) + 1 INTH = MOD(LTWIDL + INSLAT + JTWIDL - LATRD1 - 1,JTWIDL) + 1 INTH1 = MOD(INTH,JTWIDL) + 1 DO 1000 KEN=1,LEVS IF (INSLAT.EQ.JIN) GO TO 105 DO 100 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),KEN,INTH) XX(I,2) = CV(ILEFT(I),KEN,INTH1) XX(I,3) = CV(IRGHT(I),KEN,INTH) XX(I,4) = CV(IRGHT(I),KEN,INTH1) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT 100 CONTINUE GO TO 130 105 DO 110 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),KEN,INTH) XX(I,3) = CV(IRGHT(I),KEN,INTH) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT 110 CONTINUE IOUT2 = IOUT / 2 DO 120 I=1,IOUT2 XX(I,2) = CV(ILEFT(I+IOUT2),KEN,INTH) XX(I+IOUT2,2) = CV(ILEFT(I),KEN,INTH) XX(I,4) = CV(IRGHT(I+IOUT2),KEN,INTH) XX(I+IOUT2,4) = CV(IRGHT(I),KEN,INTH) 120 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) 130 DO 10 I=1,IOUT NN(I) = 0 10 CONTINUE DO 12 J=1,2 DO 12 I=1,IOUT SUM(I,J) = 0. E 0 12 CONTINUE DO 150 KPT=1,4 DO 14 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) ENDIF 14 CONTINUE DO 15 I=1,IOUT SUM(I,2) = SUM(I,2) + WGT(I,KPT) * XX(I,KPT) 15 CONTINUE 150 CONTINUE DO 16 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.49 E 0) GO TO 17 IF (NN(I).EQ.2.AND.SUM(I,1).GE.0.45 E 0) GO TO 17 IF (NN(I).GE.3) GO TO 17 CAMT(I,KEN) = 0. E 0 GO TO 18 17 CONTINUE CAMT(I,KEN) = SUM(I,2) 18 CONTINUE 16 CONTINUE 1000 CONTINUE RETURN C--- POLAR REGION-NO EXTRAPOLATION 600 CONTINUE JA = IABS(INSLAT) DO 2000 KEN=1,LEVS DO 200 I=1,IOUT C---- GET LEFT POINT ON NEAREST LATITUDE XX(I,1) = CV(ILEFT(I),KEN,JA) XX(I,2) = CV(IRGHT(I),KEN,JA) WGT(I,1) = 1. E 0-WGTLON(I) WGT(I,2) = WGTLON(I) 200 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) DO 20 I=1,IOUT NN(I) = 0 20 CONTINUE DO 22 J=1,2 DO 22 I=1,IOUT SUM(I,J) = 0. E 0 22 CONTINUE DO 202 KPT=1,2 DO 24 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) ENDIF 24 CONTINUE DO 25 I=1,IOUT SUM(I,2) = SUM(I,2) + WGT(I,KPT) * XX(I,KPT) 25 CONTINUE 202 CONTINUE DO 26 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.7 E 0) GO TO 27 IF (NN(I).EQ.2) GO TO 27 CAMT(I,KEN) = 0. E 0 GO TO 28 27 CONTINUE CAMT(I,KEN) = SUM(I,2) 28 CONTINUE 26 CONTINUE 2000 CONTINUE RETURN END SUBROUTINE CVINTF(CVIN,CVTIN,CVBIN,IIN,JTWIDL,JIN, 1 CVOUT,CVTOUT,CVBOUT,IOUT,JPOUT,JOUT, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 3 XX,WGT,TT,BB,SUM,NN, 4 LTWIDL,LATRD1,LATINB) C-- ***************************************************************** C * CODE BILINEARLY INTERPOLATES CLD AMT BETWEEN GAUSSIAN GRIDS--* C * CLONE OF GGINTP FOR INTERPOLATION OF CONVECTIVE CLD AMT (CV).* C * SPECIAL INTERP PROCEDURE FOR TOPS(CVT) AND BOTS(CVB)... * C- * J = 1 IS JUST BELO N.POLE, I = 1 IS GREENWICH (THEN GO EAST).* C * IIN,JIN ARE I,J DIMENSIONS OF INPUT GRID--IOUT,JOUT FOR OUTPUT* C * JIN2,JOUT2=JIN/2,JOUT/2 * C * --K.CAMPANA - JUNE 1988 * C-- ***************************************************************** DIMENSION CVIN(IIN,JTWIDL),CVTIN(IIN,JTWIDL),CVBIN(IIN,JTWIDL) DIMENSION CVOUT(IOUT,JPOUT) DIMENSION CVTOUT(IOUT,JPOUT),CVBOUT(IOUT,JPOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION INSLAT(JOUT),WGTLAT(JOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4),TT(IOUT,4),BB(IOUT,4),SUM(IOUT,4) DIMENSION NN(IOUT) III = IIN JBB = JTWIDL JJJ = JIN IIIOUT = IOUT LBB = LTWIDL LR1 = LATRD1 DO 50 LATOUT=1,JPOUT LAT=LATOUT+LATINB-1 CCC PRINT 100,LAT,XLAT C===> IF OUTPUT LAT IS POLEWARD OF INPUT LAT=1 ,THEN SIMPL AVERAGE C (SMALL REGION AND CLD AMT WOULDN T EXTRAPOLATE WELL) CALL CINTP(III,JBB,JJJ,IIIOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT(LAT),WGTLAT(LAT), 2 CVIN,CVTIN,CVBIN,CVOUT(1,LATOUT), 3 CVTOUT(1,LATOUT),CVBOUT(1,LATOUT), 3 XX,WGT,TT,BB,SUM,NN,LBB,LR1) 50 CONTINUE CK100 FORMAT(1H ,' ROW =',I5,' LAT =',E15.5) RETURN END SUBROUTINE CINTP(IIN,JTWIDL,JIN,IOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 2 CV,CVT,CVB,CAMT,CTOP,CBOT, 3 XX,WGT,TT,BB,SUM,NN,LTWIDL,LATRD1) DIMENSION CV(IIN,JTWIDL),CVT(IIN,JTWIDL),CVB(IIN,JTWIDL) DIMENSION CAMT(IOUT),CTOP(IOUT),CBOT(IOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4),TT(IOUT,4),BB(IOUT,4),SUM(IOUT,4) DIMENSION NN(IOUT) C SIMPL LINEAR INTERPOLATION OF CLDAMT, UNLESS ONLY 1,2 OF THE C SURROUNDING PTS HAS CV. THEN,IF OUTPUT GRIDPT NOT CLOSE ENUF C DO NOT INTERPOLATE TO IT(PREVENTS SPREADING OF CV CLDS).. C FOR 1 PT CONVECTION-INTRP WGT GE (.7)**2 ... C FOR 2 PT CONVECTION-SUM OF INTRP WGT GE .45... C .45 USED RATHER THAN .5 TO GIVE BETTER RESULT FOR C DIAGONALLY OPPOSED PTS... C===> FOR TOPS(CVT) AND BOTS(CVB) JUST TAKE AVERAGE OF SURROUNDING C NON-ZERO CV POINTS..... C NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) C--- NHSH = 1,-1 FOR NORTHERN,SOUTHERN HEMISPHERE C HERE INSTEAD OF AN EXTRAPOLATION,JUST DO A SIMPLE MEAN.... C IF (INSLAT.LT.0) GO TO 600 C INTH = MOD(LTWIDL + INSLAT - LATRD1 - 1,JTWIDL) + 1 INTH = MOD(LTWIDL + INSLAT + JTWIDL - LATRD1 - 1,JTWIDL) + 1 INTH1 = MOD(INTH,JTWIDL) + 1 IF (INSLAT.EQ.JIN) GO TO 105 DO 100 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),INTH) XX(I,2) = CV(ILEFT(I),INTH1) XX(I,3) = CV(IRGHT(I),INTH) XX(I,4) = CV(IRGHT(I),INTH1) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT TT(I,1) = CVT(ILEFT(I),INTH) TT(I,2) = CVT(ILEFT(I),INTH1) TT(I,3) = CVT(IRGHT(I),INTH) TT(I,4) = CVT(IRGHT(I),INTH1) BB(I,1) = CVB(ILEFT(I),INTH) BB(I,2) = CVB(ILEFT(I),INTH1) BB(I,3) = CVB(IRGHT(I),INTH) BB(I,4) = CVB(IRGHT(I),INTH1) 100 CONTINUE GO TO 130 105 DO 110 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),INTH) XX(I,3) = CV(IRGHT(I),INTH) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT TT(I,1) = CVT(ILEFT(I),INTH) TT(I,3) = CVT(IRGHT(I),INTH) BB(I,1) = CVB(ILEFT(I),INTH) BB(I,3) = CVB(IRGHT(I),INTH) 110 CONTINUE IOUT2 = IOUT / 2 DO 120 I=1,IOUT2 XX(I,2) = CV(ILEFT(I+IOUT2),INTH) XX(I+IOUT2,2) = CV(ILEFT(I),INTH) XX(I,4) = CV(IRGHT(I+IOUT2),INTH) XX(I+IOUT2,4) = CV(IRGHT(I),INTH) BB(I,2) = CVB(ILEFT(I+IOUT2),INTH) BB(I+IOUT2,2) = CVB(ILEFT(I),INTH) BB(I,4) = CVB(IRGHT(I+IOUT2),INTH) BB(I+IOUT2,4) = CVB(IRGHT(I),INTH) TT(I,2) = CVT(ILEFT(I+IOUT2),INTH) TT(I+IOUT2,2) = CVT(ILEFT(I),INTH) TT(I,4) = CVT(IRGHT(I+IOUT2),INTH) TT(I+IOUT2,4) = CVT(IRGHT(I),INTH) 120 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) CKAC NN(1;IOUT) = 0 CKAC SUM(1,1;IOUT*4) = 0. E 0 130 DO 10 I=1,IOUT NN(I) = 0 10 CONTINUE DO 12 J=1,4 DO 12 I=1,IOUT SUM(I,J) = 0. E 0 12 CONTINUE DO 150 KPT=1,4 CKAC WHERE (XX(1,KPT;IOUT).GT.0. E 0) CKAC NN(1;IOUT) = NN(1;IOUT) + 1 CKAC SUM(1,1;IOUT) = SUM(1,1;IOUT) + WGT(1,KPT;IOUT) CKAC SUM(1,2;IOUT) = SUM(1,2;IOUT) + TT(1,KPT;IOUT) CKAC SUM(1,3;IOUT) = SUM(1,3;IOUT) + BB(1,KPT;IOUT) CKAC ENDWHERE CKAC SUM(1,4;IOUT) = SUM(1,4;IOUT) + WGT(1,KPT;IOUT) * CKAC 1 XX(1,KPT;IOUT) DO 14 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) SUM(I,2) = SUM(I,2) + TT(I,KPT) SUM(I,3) = SUM(I,3) + BB(I,KPT) ENDIF 14 CONTINUE DO 15 I=1,IOUT SUM(I,4) = SUM(I,4) + WGT(I,KPT) * XX(I,KPT) 15 CONTINUE 150 CONTINUE CKAC WHERE((NN(1;IOUT).EQ.1 .AND. SUM(1,1;IOUT).GT.0.49 E 0) .OR. CKAC 1 (NN(1;IOUT).EQ.2 .AND. SUM(1,1;IOUT).GE.0.45 E 0) .OR. CKAC 2 NN(1;IOUT).GE.3) CKAC CTOP(1;IOUT) = VAINT(SUM(1,2;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CTOP(1;IOUT)) CKAC CBOT(1;IOUT) = VAINT(SUM(1,3;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CBOT(1;IOUT)) CKAC CAMT(1;IOUT) = SUM(1,4;IOUT) CKAC OTHERWISE CKAC CTOP(1;IOUT) = 0. E 0 CKAC CBOT(1;IOUT) = 100. E 0 CKAC CAMT(1;IOUT) = 0. E 0 CKAC ENDWHERE DO 16 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.49 E 0) GO TO 17 IF (NN(I).EQ.2.AND.SUM(I,1).GE.0.45 E 0) GO TO 17 IF (NN(I).GE.3) GO TO 17 CTOP(I) = 0. E 0 CBOT(I) = 100. E 0 CAMT(I) = 0. E 0 GO TO 18 17 CONTINUE LTOP = SUM(I,2)/NN(I) + 0.5 E 0 LBOT = SUM(I,3)/NN(I) + 0.5 E 0 CTOP(I) = LTOP CBOT(I) = LBOT CAMT(I) = SUM(I,4) 18 CONTINUE 16 CONTINUE RETURN C--- POLAR REGION-NO EXTRAPOLATION 600 CONTINUE JA = IABS(INSLAT) DO 200 I=1,IOUT C---- GET LEFT POINT ON NEAREST LATITUDE XX(I,1) = CV(ILEFT(I),JA) XX(I,2) = CV(IRGHT(I),JA) WGT(I,1) = 1. E 0-WGTLON(I) WGT(I,2) = WGTLON(I) TT(I,1) = CVT(ILEFT(I),JA) TT(I,2) = CVT(IRGHT(I),JA) BB(I,1) = CVB(ILEFT(I),JA) BB(I,2) = CVB(IRGHT(I),JA) 200 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) CKAC NN(1;IOUT) = 0 CKAC SUM(1,1;IOUT*4) = 0. E 0 DO 20 I=1,IOUT NN(I) = 0 20 CONTINUE DO 22 J=1,4 DO 22 I=1,IOUT SUM(I,J) = 0. E 0 22 CONTINUE DO 202 KPT=1,2 CKAC WHERE (XX(1,KPT;IOUT).GT.0. E 0) CKAC NN(1;IOUT) = NN(1;IOUT) + 1 CKAC SUM(1,1;IOUT) = SUM(1,1;IOUT) + WGT(1,KPT;IOUT) CKAC SUM(1,2;IOUT) = SUM(1,2;IOUT) + TT(1,KPT;IOUT) CKAC SUM(1,3;IOUT) = SUM(1,3;IOUT) + BB(1,KPT;IOUT) CKAC ENDWHERE CKAC SUM(1,4;IOUT) = SUM(1,4;IOUT) + WGT(1,KPT;IOUT) * CKAC 1 XX(1,KPT;IOUT) DO 24 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) SUM(I,2) = SUM(I,2) + TT(I,KPT) SUM(I,3) = SUM(I,3) + BB(I,KPT) ENDIF 24 CONTINUE DO 25 I=1,IOUT SUM(I,4) = SUM(I,4) + WGT(I,KPT) * XX(I,KPT) 25 CONTINUE 202 CONTINUE CKAC WHERE((NN(1;IOUT).EQ.1 .AND. SUM(1,1;IOUT).GT.0.7 E 0) .OR. CKAC 1 NN(1;IOUT).EQ.2) CKAC CTOP(1;IOUT) = VAINT(SUM(1,2;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CTOP(1;IOUT)) CKAC CBOT(1;IOUT) = VAINT(SUM(1,3;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CBOT(1;IOUT)) CKAC CAMT(1;IOUT) = SUM(1,4;IOUT) CKAC OTHERWISE CKAC CTOP(1;IOUT) = 0. E 0 CKAC CBOT(1;IOUT) = 100. E 0 CKAC CAMT(1;IOUT) = 0. E 0 CKAC ENDWHERE DO 26 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.7 E 0) GO TO 27 IF (NN(I).EQ.2) GO TO 27 CTOP(I) = 0. E 0 CBOT(I) = 100. E 0 CAMT(I) = 0. E 0 GO TO 28 27 CONTINUE LTOP = SUM(I,2)/NN(I) + 0.5 E 0 LBOT = SUM(I,3)/NN(I) + 0.5 E 0 CTOP(I) = LTOP CBOT(I) = LBOT CAMT(I) = SUM(I,4) 28 CONTINUE 26 CONTINUE RETURN END SUBROUTINE COSZMN(DTSWAV,SOLHR,SINLAT,COSLAT,SDEC,CDEC,SLAG, 1 XLON,IMX2,JMX2,COSZEN,LDG,COSZDG) CFPP$ NOCONCUR R C C===> COMPUTE MEAN COS SOLAR ZEN ANGL OVER DTSWAV HRS C.... COSINE OF SOLAR ZEN ANGL FOR BOTH N. AND S. HEMISPHERES. C SOLHR=TIME(HRS) AFTER 00Z (GREENWICH TIME).. C XLON IS EAST LONG(RADIANS).. C SINLAT, COSLAT ARE SIN AND COS OF LATITUDE (N. HEMISPHERE) C SDEC, CDEC = THE SINE AND COSINE OF THE SOLAR DECLINATION. C SLAG = EQUATION OF TIME DIMENSION XLON(IMX2,JMX2),COSZEN(IMX2,JMX2) LOGICAL LDG DIMENSION COSZDG(IMX2,JMX2) DIMENSION SINLAT(IMX2,JMX2),COSLAT(IMX2,JMX2) C LOCAL ARRAY DIMENSION COSZN( 384 ) DIMENSION ISTSUN( 384 ) NSTP = 6 ISTP = NSTP*DTSWAV PID12 = (2. E 0 * ASIN(1. E 0)) / 12. E 0 C---- DO 2000 J=1,JMX2 DO 20 I=1,IMX2 COSZEN(I,J) = 0. E 0 ISTSUN(I) = 0 20 CONTINUE DO 1000 IT=1,ISTP CNS = PID12 * (SOLHR-12. E 0+(IT-1)*1. E 0/NSTP) +SLAG DO 40 I=1,IMX2 SS=SINLAT(I,J)*SDEC CC=COSLAT(I,J)*CDEC COSZN(I) = SS + CC * COS(CNS + XLON(I,J)) CX COSZN(I) = SINLAT(I,J)*SDEC + CX 1 COSLAT(I,J)*CDEC * COS(CNS + XLON(I,J)) COSZEN(I,J) = COSZEN(I,J) + MAX (0. E 0, COSZN(I)) IF(COSZN(I).GT.0. E 0) ISTSUN(I) = ISTSUN(I) + 1 40 CONTINUE 1000 CONTINUE DO 1500 I=1,IMX2 IF(LDG) COSZDG(I,J) = COSZEN(I,J) / ISTP IF(ISTSUN(I).GT.0) COSZEN(I,J) = COSZEN(I,J) / ISTSUN(I) 1500 CONTINUE 2000 CONTINUE RETURN END SUBROUTINE GCLJMS (SI) PARAMETER (KDIM= 28 , KDIMP=KDIM+1) COMMON /COMCD1/ ROCP,PTOPC(4,2),CVTOP,VVCLD(2),CLAPSE 1, CRHRH,KLOWT,KLOWB,PSTRT 2, LLYR,LLLYR,CLAPKC,DCLPS,CLPSE DIMENSION SI(KDIMP), PPPTOP(4,2) C --- PRESSURE LIMITS FOR SFC AND TOP OF EACH CLOUD DOMAIN (L,M,H) C IN MB, MODEL LAYERS FOR CLD TOPS ARE L=7,M=11,H=15 AT LOW C LATITUDES AND L= ,M= ,H= , AT POLE REGION. C.... PTOP ABOVE H CHANGED FROM 150 TO 100, CAUSE CC DATA PPPTOP /1050.,642.,350.,150., 1050.,750.,500.,150./ C CODE WAS TRUNCATING TOPS OF CONVECTIVE CLOUDS DATA PPPTOP /1050.,642.,350.,100., 1050.,750.,500.,100./ C ROCP = 2.8705E+2 / 1.0046E+3 C --- INVERSON TYPE CLD CRITICAL VALUE-ISTRAT=0 CYH94 CLAPSE = -0.055 E 0 CLAPSE = -0.06 E 0 C --- INVERSON TYPE CLD CRITICAL VALUE-ISTRAT=1 CLAPKC = -0.05 E 0 C....CRITICAL DTHETA/DP FOR OCEAN STRATUS(WGT VARIES 0 TO 1 C LINEARLY FROM CLAPSE TO CLPSE) DCLPS = -0.01 E 0 CLPSE = CLAPKC + DCLPS CVTOP = 400.0 E 0 PSTRT = 800.0 E 0 C --- LOW CLD BOTTOM (AT SIGMA=0.95) AND TOP SIGMA LEVEL DO 5 K=1,KDIM KK=K IF (SI(KK) .LE. 0.95 E 0) GO TO 10 5 CONTINUE 10 KLOWB = KK - 1 SILOW = PPPTOP(2,1) * 1.0 E -3 DO 20 K=1,KDIM KK=K IF (SI(KK) .LT. SILOW) GO TO 30 20 CONTINUE 30 KLOWT = KK C --- PRESURE LIMIT AT SFC AND AT TOP OF CLOUD DOMAINS (L,M,H) IN MB DO 40 J=1,2 DO 40 I=1,4 PTOPC(I,J) = PPPTOP(I,J) 40 CONTINUE C --- L CLD VERTICAL VEL ADJ BOUNDARIES C C VVCLD(1) = 0.0003 E 0 C VVCLD(2) = -0.0005 E 0 C C CHANGED BY MK 5/5/98 C C VVCLD(1) = 0.0006 C VVCLD(2) = 0.0006 C TURNED OFF VERTICAL MOTION CHECK VVCLD(1) = 100. VVCLD(2) = 100. C CRHRH = 0.60 E 0 C--- COMPUTE LLYR--WHICH IS TOPMOST NON CLD(LOW) LAYER, FOR STRATIFORM XTHK = 0. E 0 C.... DEFAULT LLYR KL = KDIMP C.... TOPMOST NONCLOUD LAYER WILL BE THE ONE AT OR ABOVE LOWEST C 0.1 OF THE ATMOSPHERE.. DO 202 K=1,KDIM C XTHK = XTHK + SI(K) - SI(K+1) C IF (XTHK.LT.0.1 E 0) GO TO 202 KL = K C GO TO 204 IF (SI(K).LT.0.9 E 0) GO TO 204 202 CONTINUE 204 LLYR = KL-1 PRINT 205,LLYR,KLOWB 205 FORMAT(1H ,'-------LLYR,KLOWB =',2I5) RETURN END SUBROUTINE CLDPRP(IDIMT,PRSLV,T,CLDARY,IBEG,IPTS,XLATRD, 1 KTOP,KBTM,NCLDS,CLDLW,TAUCL,CFAC,CLDSW) CFPP$ NOCONCUR R C--------------------------------------------------------------------- C FEB., 1993 - Y.H. C CLOUD RADIATIVE PROPERTIES CALCULATIONS AFTER DAVIS (1982) C AND HARSHVARDHAN ET AL. (1987). C NOV., 1995 - Y.H. C MODIFIED TO PROVIDE MIXED CLOUD OVERLAPPING SCHEME FOR C CHOU'S SW RADIATION SCHEME (1992)_. C-------------------------------------------------------------------- C INPUT VARIABLES: C PRSLV(I,K) - LEVEL PRESSURE (MB) K=1 IS TOA C T (I,K) - ABSOLUTE TEMPERATURE, K=1 IS TOP LAYER (K) C CLDARY(I,K) - CLOUD ARRAY CONTAINS COMPRESSED CLOUD C FRACTIONS OF 3 TYPES (STRATIFORM, CONV C AND STRATUS), K=1 IS THE MDL SFC LAYER C IBEG,IPTS - INDICES FOR THE BEGINNIG NO. AND THE C TOTAL NO. OF ARRAY ELEMENTS TO BE PROCESSED C --- MODIFY XLATRD TO GENERAL FOR REGIONAL AND GLOBAL (H.-M.H. JUANGK C *** XLATRD - CURRENT LATITUDE IN RADIANS (1ST DATA PT) C FOR MODELS WITH DIFF LAT AT EACH PT, NEED TO C USE THE LAT OF EACH POINT....CAREFUL..... C OUTPUT VARIABLES: C --- CLOUDS FOR LW RAD. K=1 IS THE SFC, K=2 IS THE C LOWEST CLOUD LAYER, AND SO ON C KTOP,KBTM(I,K)- CLOUD TOP AND BOTTOM INDECES, KTOP AND C KBTM VALUES FROM 1 TO L MODEL LAYERS, C WITH VALUE OF 1 BEING THE TOP MDL LAYER C NCLDS(I) - NO. OF SEPARATED CLOUD LAYERS IN A COLUMN C CLDLW(I,K) - CLOUD FRACTIONS FOR LW, EMISSIVITY ADJUSTED C EMIS(I,K) - CLOUD EMISSIVITY C *** ITYP(I,K) - TYPE OF CLOUDS, ITYP=1, AND 2 ARE FOR C THE RH, AND CONV TYPES C --- CLOUDS FOR SW RAD. K=1 IS THE TOP LAYER OR LEVEL C TAUCL(I,K) - CLOUD OPTICAL DEPTH IN EVERY MODEL LAYER C K=1 IS THE TOP LAYER C CFAC(I,K) - FEACTION OF CLEAR SKY VIEW AT THE LAYER INTERFA C CLDSW(I,K) - LAYER CLOUD FRACTIONS FOR SW C C-------------------------------------------------------------------- C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) D I M E N S I O N 1 PRSLV(IMBX,LP1), CLDARY(IDIMT,L), XLATRD(IDIMT) 2, TAUCL(IMBX,L), T (IMBX,LP1), CLDLW(IMBX,LP1) 3, KTOP(IMBX,LP1), KBTM(IMBX,LP1), CLDSW(IMBX,L) 4, ITYP(IMBX,LP1), NCLDS(IMAX), CFAC(IMBX,LP1) C COMMON /COMCD1/ ROCP,PTOPC(4,2),CVTOP,VVCLD(2),CLAPSE 1, CRHRH,KLOWT,KLOWB,PSTRT 2, LLYR,LLLYR,CLAPKC,DCLPS,CLPSE C C --- WORKSPACE --- D I M E N S I O N 1 MTYP (IMAX), XAMT (IMAX), TAUC (IMAX) 2, KCLD (IMAX), MBTM (IMAX), CL1 (IMAX) C97 3, CL2 (IMAX), PTOPD(IMAX), ALFA (IMAX) 3, CL2 (IMAX), ALFA (IMAX) L O G I C A L 1 BITX(IMAX), BITW(IMAX), BIT1, BIT2 C===> BEGIN HERE ................................................ DO 20 I=1,IMAX KCLD(I) = 2 MBTM(I) = 1 MTYP(I) = 0 XAMT(I) = 0.0 E 0 ITYP(I,1) = 0 KTOP(I,1) = LP1 KBTM(I,1) = LP1 CLDLW(I,1)= 1.0 E 0 CFAC(I,1) = 1.0 E 0 20 CONTINUE DO 30 K=2,LP1 DO 30 I=1,IMAX ITYP(I,K) = 0 KTOP(I,K) = 1 KBTM(I,K) = 1 CLDLW(I,K) = 0.0 E 0 CLDSW(I,K-1) = 0.0 E 0 TAUCL(I,K-1) = 0.0 E 0 CFAC(I,K) = 1.0 E 0 30 CONTINUE C C --- LOOP OVER MDL LAYERS (BOTTOM UP) C DO 200 K=2,L C BIT1 = .FALSE. DO 60 I=1,IPTS IR = I + IBEG - 1 BITX(I) = CLDARY(IR,K).GT.0.0 E 0 BIT1 = BIT1 .OR. BITX(I) 60 CONTINUE IF (.NOT. BIT1) GO TO 200 C --- DECOMPRESS CLOUD ARRAY DO 70 I=1,IPTS CL1(I) = 0.0 E 0 CL2(I) = 0.0 E 0 BITW(I) = BITX(I) 70 CONTINUE DO 80 I=1,IPTS IF (BITX(I)) THEN IR = I + IBEG - 1 CL1(I) = AMOD(CLDARY(IR,K), 2.0 E 0) CLTEMP = AMOD(CLDARY(IR,K), 10.0 E 0) CL2(I) = 1.0 E -4 * (CLDARY(IR,K) - CLTEMP) C --- MTYP=1,2 FOR RH+STRATUS, AND CONV CLOUD TYPES IF (CL2(I) .GT. 0.0 E 0) THEN MTYP(I) = 2 ELSE MTYP(I) = 1 END IF END IF 80 CONTINUE IF(K.LT.L) THEN DO 100 I=1,IPTS IR = I + IBEG - 1 IF(BITW(I)) THEN BITW(I) = CLDARY(IR,K+1).LE.0.0 E 0 ENDIF 100 CONTINUE ENDIF BIT2 = .FALSE. DO 110 I=1,IPTS BIT2 = BIT2 .OR. BITW(I) IF (BITX(I)) THEN IF(ITYP(I,KCLD(I)).EQ.0) THEN ITYP(I,KCLD(I)) = MTYP(I) XAMT(I) = CL1(I) IF (MTYP(I) .EQ. 2) XAMT(I) = CL2(I) MBTM(I) = K ELSE IF(ITYP(I,KCLD(I)).NE.MTYP(I) .OR. 1 (MTYP(I).EQ.2 .AND. XAMT(I).NE.CL2(I)) ) THEN CLDLW(I,KCLD(I)) = XAMT(I) KTOP(I,KCLD(I)) = LP1 - (K - 1) KBTM(I,KCLD(I)) = LP1 - MBTM(I) ITYP(I,KCLD(I)+1) = MTYP(I) MBTM(I) = K XAMT(I) = CL1(I) IF (MTYP(I).EQ.2) XAMT(I) = CL2(I) KCLD(I) = KCLD(I) + 1 ELSE IF(MTYP(I).EQ.1) THEN XAMT(I) = AMAX1(XAMT(I), CL1(I)) ENDIF END IF 110 CONTINUE IF (.NOT. BIT2) GO TO 200 DO 160 I=1,IPTS IF (BITW(I)) THEN CLDLW(I,KCLD(I)) = XAMT(I) KTOP(I,KCLD(I)) = LP1 - K KBTM(I,KCLD(I)) = LP1 - MBTM(I) KCLD(I) = KCLD(I) + 1 MTYP(I) = 0 MBTM(I) = 1 XAMT(I) = 0.0 E 0 END IF 160 CONTINUE C 200 CONTINUE C --- RECORD NUM OF CLD LYRS AND FIND MAX NUM OF CLD LYRS MCLDS = 0 DO 220 I=1,IPTS NCLDS(I) = KCLD(I) - 2 MCLDS = MAX(MCLDS, NCLDS(I)) 220 CONTINUE C WRITE(6,221) MCLDS, IBEG C221 FORMAT(' IN CLDPRP: MAXCLDS =',I4,' IBEG=',I4) C IF (MCLDS .EQ. 0) RETURN C C --- ESTIMATE CLOUD OPTICAL PROPERTIES FROM T AND Q C (TOP DOWN) C DO 400 NNCLD=1,MCLDS NC = MCLDS - NNCLD + 2 C DO 230 I=1,IPTS TAUC(I) = 0.0 E 0 BITX(I) = CLDLW(I,NC) .GT. 0.0 E 0 BITW(I) = BITX(I) CCONV - REDUCE CONV CLOUD AMOUNT FOR SW RAD IF (ITYP(I,NC) .EQ. 2) THEN ALFA(I) = AMAX1(0.25 E 0, 1 1.0 E 0-0.125 E 0*(KBTM(I,NC)-KTOP(I,NC))) ELSE ALFA(I) = 1.0 E 0 END IF 230 CONTINUE C --- FIND TOP PRESSURE FOR MID CLOUD (3) DOMAIN=FUNCTION OF LATITUDE MINKTP=LP1 MAXKBT=1 DO 240 I=1,IPTS IF (BITX(I)) THEN MINKTP = MIN(MINKTP,KTOP(I,NC)) MAXKBT = MAX(MAXKBT,KBTM(I,NC)) END IF 240 CONTINUE C write(6,241) NC,MINKTP, MAXKBT C241 format(3x,'NC, MINKTP, MAXKBT =',3I6/3X,'BITX, BITW :') IF (NNCLD .EQ. 1) KSTRT = MINKTP C --- CALC CLD THICKNESS DELP AND MEAN TEMP (CELSIUS) DO 260 KK=MINKTP,MAXKBT DO 260 I=1,IPTS IF (KK.GE.KTOP(I,NC) .AND. KK.LE.KBTM(I,NC) .AND.BITX(I)) THEN DELP = PRSLV(I,KK+1) - PRSLV(I,KK) TCLD = T(I,KK) - 273.16 E 0 C --- CONVECTIVE CLOUD IF (ITYP(I,NC) .EQ. 2) THEN TAU0 = DELP * 0.06 E 0 C --- RH CLOUDS ELSE IF (TCLD .LE. -10.0 E 0) THEN TAU0 = DELP 1 * AMAX1(0.1 E -3, 2.00 E -6*(TCLD+82.5 E 0)**2) ELSE TAU0 = DELP*AMIN1(0.08 E 0, 6.949 E -3*TCLD+0.08 E 0) END IF END IF TAUC(I) = TAUC(I) + TAU0 CLDSW(I,KK) = CLDLW(I,NC) TAUCL(I,KK) = TAU0 * ALFA(I) * CLDLW(I,NC) IF (BITW(I)) THEN CFAC(I,KK+1) = CFAC(I,KK) * (1.0 E 0 - CLDSW(I,KK)) BITW(I) = .FALSE. ELSE CFAC(I,KK+1) = CFAC(I,KK) END IF ELSEIF (KK.GT.KBTM(I,NC) .AND. BITX(I)) THEN CFAC(I,KK+1) = CFAC(I,KK) END IF 260 CONTINUE MKBTP1 = MAXKBT + 1 DO 280 K=MKBTP1,L DO 280 I=1,IPTS IF (BITX(I)) CFAC(I,K+1) = CFAC(I,MKBTP1) 280 CONTINUE C --- CALC CLD EMIS DO 320 I=1,IPTS IF (BITX(I)) 1 CLDLW(I,NC) = CLDLW(I,NC)*(1.0 E 0-EXP(-0.75 E 0*TAUC(I))) 320 CONTINUE C 400 CONTINUE C --- CLOUD SCALED FOR SW DO 420 KK=1,L DO 420 I=1,IPTS IF (CFAC(I,LP1) .LT. 1.0 E 0) 1 TAUCL(I,KK) = TAUCL(I,KK) / (1.0 E 0 - CFAC(I,LP1)) 420 CONTINUE IF (IPTS .EQ. IMAX) GO TO 565 IPTS1 = IPTS + 1 DO 520 I=IPTS1,IMAX NCLDS(I) = NCLDS(IPTS) 520 CONTINUE DO 540 K=1,LP1 DO 540 I=IPTS1,IMAX CLDLW(I,K) = CLDLW(IPTS,K) KTOP(I,K) = KTOP(IPTS,K) KBTM(I,K) = KBTM(IPTS,K) CFAC(I,K) = CFAC(IPTS,K) 540 CONTINUE DO 560 K=1,L DO 560 I=IPTS1,IMAX TAUCL(I,K) = TAUCL(IPTS,K) CLDSW(I,K) = CLDSW(IPTS,K) 560 CONTINUE 565 CONTINUE C WRITE(6,581) IBEG C581 FORMAT(' IN CLDPRP: PRINT LW CLOUDS, IBEG=',I5) C DO 586 K=2,MCLDS+1 C WRITE(6,582) K C582 FORMAT(' FROM SFC AND UP, CLD NUM =',I5,' CLDLW,EMIS,TOP,BOT') C WRITE(6,583) (CLDLW(I,K),EMIS(I,K),KTOP(I,K), C 1 KBTM(I,K),I=1,IMAX) C583 FORMAT(6(2F6.3,2I4)) C586 CONTINUE C C WRITE(6,591) C591 FORMAT(' IN CLDPRP: PRINT SW CLOUDS') C DO 596 K=KSTRT,L C WRITE(6,592) K C592 FORMAT(' FROM TOP AND DN, LEV NUM =',I5,' CLDSW,CFAC,TAU') C WRITE(6,593) (CLDSW(I,K),CFAC(I,K+1),TAUCL(I,K),I=1,IMAX) C593 FORMAT(6(3F6.3,2X)) C596 CONTINUE C RETURN END SUBROUTINE CRHTAB(RHCL,IER) C--------------------------------------------------------------------- C.. CLD-RH RELATIONS OBTAINED FROM MITCHELL-HAHN PROCEDURE, HERE READ C CLD/RH TUNING TABLES FOR DAY 0,1,...,5 AND MERGE INTO 1 FILE.. C .............K.A.C. MAR 93 C USE ONLY ONE TABLE (DAY 1) FOR ALL FCST HRS....K.A.C. FEB 94 c... 4 cld types .... KAC FEB96 c... smooth out last bunch of bins of the tables...KAC AUG97 C OUTPUT: C RHCL - TUNING TABLES FOR ALL FORECAST DAYS C IER - =1 IF TABLES AVAILABLE.. =-1 IF NO TABLES C-------------------------------------------------------------------- CRH1T PARAMETER (MCLD=3,NSEAL=2,IDA=6, CMCL4 PARAMETER (MCLD=4,NSEAL=2,IDA=1, PARAMETER (MCLD=3,NSEAL=2,IDA=1, 1 NBIN=100,NLON=2,NLAT=4) DIMENSION RHFD(NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION RRHFD(NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION RTNFFD(NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION RRNFFD(NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION RHCF(NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION RTNFCF(NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION KPTS(NLON,NLAT,MCLD,NSEAL) DIMENSION KKPTS(NLON,NLAT,MCLD,NSEAL) DIMENSION RHC(NLON,NLAT,MCLD,NSEAL) DIMENSION RHCL (NBIN,NLON,NLAT,MCLD,NSEAL,IDA) DIMENSION RHCLA(NBIN,NLON,NLAT,MCLD,NSEAL) DIMENSION ICDAYS(15),IDATE(4) C........................... BEGIN HERE .............. IER = 1 DO 8000 ITIM=1,IDA ICFQ = 43 + ITIM-1 REWIND ICFQ Cmcl3 NCLDS=1,2,3 (L,M,H)..JSL=1,2 (LAND,SEA) cmcl4 MCLD=1,2,3,4 (BL,L,M,H) BINSCL = 1./NBIN DO 1000 M=1,NSEAL DO 1000 L=1,MCLD DO 1000 K=1,NLAT DO 1000 J=1,NLON DO 1000 I=1,NBIN RRHFD(I,J,K,L,M) = 0. RRNFFD(I,J,K,L,M) = 0. 1000 CONTINUE DO 1001 M=1,NSEAL DO 1001 L=1,MCLD DO 1001 K=1,NLAT DO 1001 J=1,NLON KKPTS(J,K,L,M) = 0 1001 CONTINUE C.... READ THE DATA OFF THE ROTATING FILE READ (ICFQ,ERR=998,END=999) NBDAYI,ICDAYS PRINT 11,NBDAYI DO 53 LD=1,NBDAYI ID = ICDAYS(LD) / 10000 IM = (ICDAYS(LD)-ID*10000) / 100 IY = ICDAYS(LD)-ID*10000-IM*100 PRINT 51,ID,IM,IY 53 CONTINUE READ (ICFQ,ERR=998,END=999) FHOUR,IDATE PRINT 3003,IDATE,FHOUR,ITIM DO 1300 KD=1,NBDAYI READ (ICFQ) RHFD READ (ICFQ) RTNFFD READ (ICFQ) KPTS DO 1002 M=1,NSEAL DO 1002 L=1,MCLD DO 1002 K=1,NLAT DO 1002 J=1,NLON DO 1002 I=1,NBIN RRHFD(I,J,K,L,M) = RRHFD(I,J,K,L,M) + RHFD(I,J,K,L,M) RRNFFD(I,J,K,L,M) = RRNFFD(I,J,K,L,M)+RTNFFD(I,J,K,L,M) 1002 CONTINUE DO 1003 M=1,NSEAL DO 1003 L=1,MCLD DO 1003 K=1,NLAT DO 1003 J=1,NLON KKPTS(J,K,L,M) = KKPTS(J,K,L,M) + KPTS(J,K,L,M) 1003 CONTINUE 1300 CONTINUE C DO 1004 M=1,NSEAL DO 1004 L=1,MCLD DO 1004 K=1,NLAT DO 1004 J=1,NLON DO 1004 I=1,NBIN RHCF(I,J,K,L,M) = RRHFD(I,J,K,L,M) RTNFCF(I,J,K,L,M) = RRNFFD(I,J,K,L,M) 1004 CONTINUE DO 1005 M=1,NSEAL DO 1005 L=1,MCLD DO 1005 K=1,NLAT DO 1005 J=1,NLON KPTS(J,K,L,M) = KKPTS(J,K,L,M) 1005 CONTINUE C..... COMPUTE THE CUMULATIVE FREQUENCY DISTRIBUTION.. DO 200 N=1,NSEAL DO 200 K=1,MCLD DO 200 L=1,NLAT DO 200 J=1,NLON DO 190 I=2,NBIN RHCF(I,J,L,K,N) = RHCF(I-1,J,L,K,N) + RHCF(I,J,L,K,N) RTNFCF(I,J,L,K,N)=RTNFCF(I-1,J,L,K,N) + RTNFCF(I,J,L,K,N) 190 CONTINUE 200 CONTINUE DO 300 N=1,NSEAL DO 300 L=1,NLAT DO 300 J=1,NLON DO 300 K=1,MCLD DO 300 I=1,NBIN IF (KPTS(J,L,K,N).GT.0) THEN RHCF(I,J,L,K,N) = RHCF(I,J,L,K,N) / KPTS(J,L,K,N) RTNFCF(I,J,L,K,N) = RTNFCF(I,J,L,K,N) / KPTS(J,L,K,N) c... cause we mix calculations of rh retune with cray and ibm words c the last value of rhcf is close to but ne 1.0, c so we reset it in order that the 360 loop gives compleat tabl c... rtnfcf caused couple of problems, seems to be ever so slightly c gt 1.0 IF (I.EQ.NBIN) THEN RHCF(I,J,L,K,N) = 1.0 END IF IF (RTNFCF(I,J,L,K,N).GE.1.0) THEN RTNFCF(I,J,L,K,N) = 1.0 END IF ELSE RHCF(I,J,L,K,N) = -0.1 RTNFCF(I,J,L,K,N) = -0.1 END IF 300 CONTINUE DO 255 NSL=1,NSEAL DO 255 KCL=1,MCLD PRINT 264,KCL,NSL PRINT 265,((KPTS(I,L,KCL,NSL),I=1,NLON),L=1,NLAT) 255 CONTINUE DO 360 NSL=1,NSEAL DO 360 K=1,MCLD DO 360 L=1,NLAT DO 360 J=1,NLON IF (KPTS(J,L,K,NSL).LE.0) GO TO 317 DO 320 I=1,NBIN ICRIT = I IF (RHCF(I,J,L,K,NSL).GE.RTNFCF(1,J,L,K,NSL)) GO TO 350 320 CONTINUE C... NO CRITICAL RH 317 ICRIT=-1 PRINT 210,L,J,NSL PRINT 202 DO 135 I=1,NBIN PRINT 203,RHCF(I,J,L,K,NSL),RTNFCF(I,J,L,K,NSL) 135 CONTINUE 350 RHC(J,L,K,NSL) = ICRIT * BINSCL 360 CONTINUE DO 1210 NSL=1,NSEAL DO 1210 K=1,MCLD PRINT 1221,K,NSL DO 1210 L=1,NLAT PRINT 211,(RHC(J,L,K,NSL),J=1,NLON) 1210 CONTINUE DO 450 NSL=1,NSEAL DO 450 KEN=1,MCLD DO 450 L=1,NLAT DO 450 JL=1,NLON DO 400 I=1,NBIN RHCL(I,JL,L,KEN,NSL,ITIM) = -0.1 400 CONTINUE 450 CONTINUE DO 751 NSL=1,NSEAL DO 751 KEN=1,MCLD DO 751 L=1,NLAT DO 751 JL=1,NLON IF (KPTS(JL,L,KEN,NSL).LE.0) GO TO 751 DO 753 I=1,NBIN DO 755 J=1,NBIN IF (RHCF(J,JL,L,KEN,NSL).GE.RTNFCF(I,JL,L,KEN,NSL)) THEN RHCL(I,JL,L,KEN,NSL,ITIM) = J*BINSCL GO TO 753 END IF 755 CONTINUE 753 CONTINUE 751 CONTINUE DO 3000 LON=1,NLON DO 3000 LAT=1,NLAT DO 3000 NC=1,MCLD DO 3000 NSL=1,NSEAL ISAT = 0 DO 67 IT=1,NBIN CFRAC = BINSCL * (IT-1) IF (RHCL(IT,LON,LAT,NC,NSL,ITIM).LT.0.) THEN PRINT 1941,IT,NSL,NC,LAT,LON STOP END IF IF (IT.LT.NBIN.AND.RTNFCF(IT,LON,LAT,NC,NSL).GE.1.) THEN IF (ISAT.LE.0) THEN ISAT = IT RHSAT = RHCL(IT,LON,LAT,NC,NSL,ITIM) CLSAT = CFRAC END IF RHCL(IT,LON,LAT,NC,NSL,ITIM) = 1 RHSAT + (1.-RHSAT)*(CFRAC-CLSAT)/(1.-CLSAT) END IF IF (IT.EQ.NBIN) RHCL(IT,LON,LAT,NC,NSL,ITIM) = 1. 67 CONTINUE 3000 CONTINUE c... smooth out the table as it reaches rh=1.0, via linear interpolation c between location of rh ge .98 and the NBIN bin (where rh=1.0) c... previously rh=1.0 occurred for many of the latter bins in the c table, thereby giving a cloud value of less then 1.0 for rh=1.0 nb=nbin-2 DO 4000 LON=1,NLON DO 4000 LAT=1,NLAT DO 4000 NC=1,MCLD DO 4000 NSL=1,NSEAL do 4167 it=1,nbin RHCLA(IT,LON,LAT,NC,NSL)=RHCL(IT,LON,LAT,NC,NSL,ITIM) 4167 continue DO 4067 IT=1,nb ibs=it cfrac=binscl*ibs IF (RHCL(IT,LON,LAT,NC,NSL,ITIM).ge..98) THEN CC Print 4011,nsl,nc,lat,lon,ibs,nbin CC 4011 format (1h ,'nsl,nc,lat,lon,ibs,nbin=',6i4) do 4068 kt=ibs,nbin cstem=binscl*kt RHCLA(kt,LON,LAT,NC,NSL) = 1 rhcl(ibs,LON,LAT,NC,NSL,ITIM)+ 2 (rhcl(nbin,LON,LAT,NC,NSL,ITIM) 3 -rhcl(ibs,LON,LAT,NC,NSL,ITIM))* 3 (cstem-cfrac)/(1.-cfrac) c if (nc.eq.2.and.lat.eq.2.and.lo.eq.1.and.nsl.eq.2) then c print 4012,kt,cstem,cfrac,rhcl(ibs,LON,LAT,NC,NSL,ITIM), c 1 RHCLA(kt,LON,LAT,NC,NSL) c 4012 format(1h ,'kt,cs,cf,rhibs,rhcla=',i5,4f12.8) c end if 4068 continue go to 4000 end if 4067 CONTINUE 4000 CONTINUE c... restore table data to preferred location.. DO 4200 LON=1,NLON DO 4200 LAT=1,NLAT DO 4200 NC=1,MCLD DO 4200 NSL=1,NSEAL DO 4200 IT=1,NBIN RHCL(IT,LON,LAT,NC,NSL,ITIM)= RHCLA(IT,LON,LAT,NC,NSL) 4200 CONTINUE 8000 CONTINUE DO 8001 KEN=1,IDA ICFQ = 42 + KEN REWIND ICFQ 8001 CONTINUE RETURN 998 PRINT 988,ITIM IER = -1 RETURN 999 PRINT 989,ITIM IER = -1 RETURN 11 FORMAT(1H ,' DAYS ON FILE =',I5) 51 FORMAT(1H ,' ARCHV DATA FROM DA,MO,YR=',3I4) 202 FORMAT(1H0,' MODEL RH ',' OBS RTCLD') 203 FORMAT(2F10.2) 210 FORMAT(1H ,' NO CRIT RH FOR LAT=',I3,' AND LON BAND=',I3, 1 ' LAND(=1) SEA=',I3) 211 FORMAT(1H ,15F6.2) 264 FORMAT(1H ,' NUMBER OF GG POINTS USED IN EACH AREA..BY LATITUDE', 1 '..FOR CLOUD TYPE=',I4,'SEALAND=',I2) 265 FORMAT(1H ,15I8) 988 FORMAT(1H ,'....ERROR READING TABLES FOR TIME=',I4) 989 FORMAT(1H ,'....E.O.F READING TABLES FOR TIME=',I4) 1221 FORMAT(1H0,' CRITICAL RH FOR LON,LAT ARRAYS FOR CLD TYPE=',I3, 1 ' LAND(=1) SEA=',I3) 1941 FORMAT(1H ,' NEG RHCL FOR IT,NSL,NC,LAT,LON=',5I4,'...STOPPP..') 3003 FORMAT(5X,'...LAST DATE/TIME AND CURRENT ITIM',/,10X, 1 4I15,F7.1,I6) END BLOCK DATA SUPPL1 COMMON /PRFSAV/ LATLONP,MLATLON,RLAT( 94 ), 1 WGT( 94 ),IB(18),IE(18) COMMON /GLBSAV/ LATLONG,LLATLON,J30,J60,WTSUM(5) C DATA LATLONP/0/ DATA LATLONG/0/ C END PROGRAM GSM C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C MAIN PROGRAM: FCST MAKE GLOBAL FORECAST WITH SPECTRAL MODEL C PRGMMR: SELA ORG: NMC23 DATE: 81-01-01 C C ABSTRACT: MAKE GLOBAL FORECAST WITH SPECTRAL MODEL. C C PROGRAM HISTORY LOG: C 81-01-01 SELA C C INPUT FILES: C UNIT 11 SIGMA FILE (ANALYSIS OR AT TIME T-DT) C UNIT 12 SIGMA FILE (AT TIME T IF NOT ANALYSIS) C UNIT 14 SURFACE FILE C UNIT 15 CO2 CONSTANTS (DEPENDENT ON VERTICAL RESOLUTION) C UNIT 24 MOUNTAIN VARIANCE (DEPENDENT ON HORIZONTAL RESOLUTION) C UNIT 43 CLOUD TUNING C C OUTPUT FILES: C UNIT 51 SIGMA FILE (AT TIME T-DT) C UNIT 52 SIGMA FILE (AT TIME T) C UNIT 53 SURFACE FILE C UNIT 61 INITIAL ZONAL DIAGNOSTICS C UNIT 63 FLUX DIAGNOSTICS C UNIT 64 FINAL ZONAL DIAGNOSTICS C UNIT 67 GRID POINT DIAGNOSTICS C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C C$$$ C.... C................................................................. C................BEGIN TWOLOOP(COMFIBM)........................ C.... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.................SOF TWOLOOP(COMFIBM)........................ C................................................................ C...SOF INCLUDE.......................................... C FORECAST SELECTION PARAMETERS COMMON/COMCON/ CON(1700),NUM(1700) PARAMETER(NVRKEN= 80 + 8 * 28 ,NPTKEN= 30 ) PARAMETER(NSTKEN= 48 ) COMMON/COMGPD/ SVDATA(NVRKEN,NPTKEN,NSTKEN), 1 IGRD(NPTKEN),JGRD(NPTKEN), 2 IGRDR(NPTKEN),JGRDR(NPTKEN), 3 ITNUM,NPOINT,ISAVE,ISSHRT,ILSHRT,IKFREQ C C COMMON/COMLFM/ WEIGHT(1000) COMMON/COMLFM/ FQ( 4033 ) COMMON/COMLFM/ FTE( 4033 , 28 ) COMMON/COMLFM/ FDI( 4033 , 28 ) COMMON/COMLFM/ FZE( 4033 , 28 ) COMMON/COMLFM/ FRQ( 4033 , 28 ) COMMON/COMLFM/ FTSEA( 384 , 47 ),FSMC( 384 , 47 , 2 ), 1 FSHELEG( 384 , 47 ),FSTC( 384 , 47 , 2 ), 2 FTG3( 384 , 47 ),FZORL( 384 , 47 ), 3 FPLANTR( 384 , 47 ), 4 FCV( 384 , 47 ),FCVB( 384 , 47 ),FCVT( 384 , 47 ), 5 FALBEDO( 384 , 47 ),FSLMSK( 384 , 47 ), 6 FF10M( 384 , 47 ),FCANOPY( 384 , 47 ) COMMON/COMLFM/ ISLMSK( 384 , 47 ,3), 1 WCVB( 384 , 47 ),WCVT( 384 , 47 ) COMMON/COMLFM/ FILTWIN,KLENP,NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO C C-WAV COMMON/COMWAV/ HSTR,USTRGG( 384 , 47 ),VSTRGG( 384 , 47 ) C.......................................... CCCCRA CALL W3LOG('$S','$M') CCSGI integer*4 set_fs_bit CCSGI integer*4 get_fs_bit CCSGI external set_fs_bit CCSGI external get_fs_bit CCSGI nsetfs=set_fs_bit() CCSGI print *,'MAINSMF setfsbit=',nsetfs CCSGI mgetfs=get_fs_bit() CCSGI print *,'MAINSMF getfsbit=',mgetfs C CALL GETCON(N1,N2,NGES,NRADR,NRADF,NNMOD, 1 N3,N4,NFLPS,NSIGI,NSIGS,NSFCI,NZNLI,NSFCF,NZNLF,NSFCS,NZNLS, 2 NDGI,NDGF,NGPKEN, 3 MODS,NITER,INI,NSTEP,NFILES, C-RSM3 NRSMI1,NRSMI2,NRFLIP, C-RSM& NRSMO1,NRSMO2,NRFLOP,NRSFLI,NRSFLX,NRINIT,NRPKEN, C-LFM& NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO,KLENP,WEIGHT,FILTWIN, 4 KSOUT,IFGES,IBRAD) C WRITE(6,*) 'NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO,KLENP,WGHT,FLTWIN=', 1 NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO,KLENP,(WEIGHT(I),I=1,10), 2 FILTWIN C C DFINI: DO DIGITAL FILTER INITIALIZATION SETUP C NUMMAX AND NUMSUM SAVED AND PASSED IN COMVER C-DFI IF( CON(3).NE.0.0 ) THEN C-DFI NUMMAX=NINT(CON(3)*3600./CON(1)/2.) C-DFI NUMSUM=-NUMMAX-1 C-DFI PRINT *,' DO GSM DIGITAL FILTER INITIALIZATION ' C-DFI CALL DFINI(0,CON(3),CHOUR,SOLSEC) C-DFI ELSE C-DFI NUMMAX=0 C-DFI NUMSUM=-1 C-DFI ENDIF KDT=1 INISTP=0 C IF(IBRAD.NE.1) THEN CALL GETRAD(NRADR,Q,QM,SFCNSW,SFCDLW,COSZEN,SDEC,CDEC,SLAG, 1 SWH,HLW) ENDIF C CALL INDDIA CALL ZERDIA(FHOUR) CALL ZNLZER C-WAV IF(DTWAVE.GT.0.) THEN C-WAV HSTR=FHOUR C-WAV USTRGG=0. C-WAV VSTRGG=0. C-WAV ENDIF IF(INI.NE.0)THEN ISAVE=0 NANLH=81 NGESH=80 NGEST=82 NGESTH=83 IF(INI.EQ.2.AND.IFGES.EQ.1) THEN CALL DIABH(NGES,NGESH,NSTEP,INI,N1) C-DBG print *,'main diabh' ENDIF IF( IFGES.EQ.1)THEN CALL GEST(NGES,NGEST,N1) C-DBG print *,' main gest ' ENDIF IF(INI.EQ.2) THEN CALL DIABH(N1 ,NANLH,NSTEP,INI,N1) C-DBG print *,' main diabh' ENDIF CALL DOINI(N1,NANLH,IFGES,NGEST,NGESH,NGESTH,MODS,NITER, 1 NNMOD,INI) C-DBG print *,' main doini' IF(NUM(13).EQ.0) GO TO 5 CALL TWRITE(NSIGI,FHOUR,IDATE,Z,Q,TE,DI,ZE,RQ,SL,SI,GZ,Z00,N1) WRITE(NSIGI)GESHEM CLOSE(NSIGI) 5 CONTINUE CALL ZERDIA(FHOUR) CALL ZNLZER C-WAV IF(DTWAVE.GT.0.) THEN C-WAV HSTR=FHOUR C-WAV USTRGG=0. C-WAV VSTRGG=0. C-WAV ENDIF CALL STEP1(JUNK1,JUNK1,0,INI,JUNK1,SOLSEC) ELSE IF(FHOUR.EQ.0.)CALL STEP1(N1,N1,1,INI,N1,SOLSEC) IF(FHOUR.NE.0.)CALL STEP1(N1,N2,1,INI,JUNK1,SOLSEC) ENDIF C C DFINI : CALL AFTER STEP1 C-DFI IF( CON(3).NE.0.0 ) THEN C-DFI CALL DFINI(1,CON(3),CHOUR,SOLSEC) C-DFI ENDIF C-DFI LIMLOW=LIMLOW-NUMMAX IF(FHOUR.EQ.0.) KDT=1 IF(FHOUR.EQ.0.) THOUR=FHOUR+DELTIM/3600. IF(FHOUR.EQ.0.) THEN CALL GLOOPZ(NZNLI,NSFCI) C-DBG print *,' main gloopz ' ENDIF IF(FHOUR.EQ.0.) & CALL WRIDIA (FHOUR,FHOUR,IDATE,SL,COLRAB,SLMSK, & TSEA,SMC,SHELEG,STC,TG3,CANOPY, & ZORL,GESHEM,BENGSH,DUSFC,DVSFC,DTSFC,DQSFC, & FLUXR,CVAVG,ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, & NDGI) C............................................................... C RSM : INITIAL CALL TO REGIONAL SPECTRAL MODEL C-RSM CALL RSMINI(FHOUR,FILTA,NCPUS,N1,N2, C-RSM& NRSMI1,NRSMI2,NRFLIP, C-RSM& NRSMO1,NRSMO2,NRFLOP,NRSFLI,NRSFLX,NRINIT,NRPKEN) C............................................................... C... SMOOTH START C............................................................... DELTIM=CON(1) MAXSTP=NUM(7) ISTEPS=NUM(8) XHOUR=SHOUR INISTP=0 C-CRA TSTEP0=TIMEF()*0.001 81 FORMAT(1H ,'KDT IN MAIN=',I3) DTHR = DELTIM/3600. E 0 HDTHR = 0.5 * DTHR C C-LFM IF(FHOUR.EQ.0.) THEN C-LFM IPSTEP=1 C-LFM ELSE C-LFM CALL LFMFINI(IPSTEP,FHOUR) C-LFM ICSTEP=NINT(FHOUR*3600./DELTIM)+1 C-LFM WRITE(6,*) 'IPSTEP FROM LFMFINI IN MAINSMF=',IPSTEP C-LFM WRITE(6,*) 'ICSTEP COMPUTED FROM FHOUR=',ICSTEP C-LFM ENDIF C AVPRS0=0. CALL GLOOPP(Q,AVPRS0) C DO 20000 ISTEP=1,ISTEPS C................................................ C... TIME LOOP C................................................ CALL GSICDF(DELTIM,AM,BM,GV,SV,CM) C-DBG print *,' main gsicdf ' IF(NPOINT.GT.0) THEN ISAVE = 1 ITNUM = 1 IF(FHOUR.EQ.0.) THEN IF(ISTEP.EQ.1) THEN IF (IKFREQ.GT.1) ISAVE = 0 IF (IKFREQ.EQ.1) ITNUM = 2 END IF END IF END IF DO 10000 JDT=LIMLOW,MAXSTP IF(NPOINT.GT.0.AND.ITNUM.GT.NSTKEN) THEN PRINT *,'KEN POINTS DISABLED - TIME LEVELS EXCEED ',NSTKEN NPOINT=0 ENDIF KDT=JDT PRINT 81,KDT C-SGI CALL FLUSH(6) LASTEP=KDT.EQ.MAXSTP.OR. & (KSOUT.GT.0.AND.MOD(KDT,MAX(KSOUT,1)).EQ.0) C C RADIATION CALCULATION C CALL GLOOPR C-DBG print *,' main gloopr ' SHOUR=SHOUR+DELTIM XHOUR=XHOUR+DELTIM CHOUR=SHOUR/3600. E 0 RHOUR=FHOUR+CHOUR C IF(ENDHOUR.GT.0..AND.RHOUR.GE.ENDHOUR) THEN C PRINT "(/' FORECAST DONE. RHOUR,ENDHOUR=',2F6.1)",RHOUR,ENDHOUR C STOP 'TOOSOON' C ENDIF IHOUR=CHOUR+0.5 E 0 CHOUR=IHOUR THOUR=FHOUR+CHOUR CALL GLOOPA C-DBG print *,' main gloopa ' C... CALL SICDIF(DIM,TEM,QM,X,Y,Z,ULN,VLN) C-DBG print *,' main sicdif ' C-DBG call flush(6) CALL DELDIF(RT,W,DELTIM,QM,SL,X,Y) C-DBG print *,' main deldif ' DO 25500 J=1, 4032 QM(J)=Q(J) Q(J)=Z(J) 25500 CONTINUE CALL FILTR1(TEM,TE,Y,DIM,DI,X,ZEM,ZE,W,RM,RQ,RT,FILTA) C-DBG print *,' main filtr1 ' C C... SET SWITCH FOR SAVING KUO DATA (FOR INTERACTIVE CLOUDS).. CVMOD= MOD (SOLHR+DTHR,DTCVAV) IF(CVMOD.LT.HDTHR.OR.CVMOD.GE.DTCVAV-HDTHR) THEN CLSTP=MIN(DTCVAV,SHOUR/3600.) ELSEIF(CLSTP.GT.0.) THEN CLSTP=0. ELSE CLSTP=-10. ENDIF CALL GLOOPB C-DBG print *,' main gloopb ' CALL DAMPUX(X,W,Y,RT,DELTIM,ULN,VLN,SPDMAX) C-DBG print *,' main dampux ' CALL FILTR2(TEM,TE,Y,DIM,DI,X,ZEM,ZE,W,RM,RQ,RT,FILTA) C-DBG print *,' main filtr2 ' C-WAV IF(DTWAVE.GT.0.) CALL GWAVE(RHOUR) C C LFM FILTERING C C-LFM IFSTEP=KDT+IPSTEP C-LFM CALL LFMFILT(IFSTEP,THOUR) C C DFINI : CALL DIGITAL FILTER INITIALIZATION EVERY STEP IF CON(3).GT.0.0 C-DFI IF( CON(3).NE.0.0 ) CALL DFINI(1,CON(3),CHOUR,SOLSEC) C C ADVANCE SOLHR C SOLSEC=SOLSEC+DELTIM SOLHR=SOLSEC/3600. E 0 IDAY=SOLHR/24. E 0 SOLHR=SOLHR-IDAY*24. E 0 C..... FOR GRID POINT DIAG ADVANCE ITNUM, IF PROPER TIME, AND SET ISAVE ISAVE = 0 C-DFI IF(NUMSUM.LT.0) THEN IF (IKFREQ.GT.1) THEN IMODK = MOD(JDT,IKFREQ) IF (IMODK.EQ.0) THEN ISAVE = 1 ITNUM = ITNUM + 1 END IF ELSE ISAVE = 1 ITNUM = ITNUM + 1 END IF C-DFI END IF C C CH6CK FOR INTERMEDIATE OUTPUT C IF(KSOUT.GT.0.AND.MOD(KDT,MAX(KSOUT,1)).EQ.0.AND.KDT.NE.MAXSTP) & THEN KSOUT=0 XHOUR=0. E 0 C WRITE INTERMEDIATE ASFC FILE CALL FIXIO(THOUR,TSEA,SMC,SHELEG,STC,TG3,ZORL,PLANTR, 1 CV,CVB,CVT,ALBEDO,SLMSK,F10M,CANOPY,1,NFLIP,NFLPS) C-DBG print *,' main fixio ' C WRITE INTERMEDIATE SIGMA FILE CALL TWRITE(NSIGS,THOUR,IDATE,Z,Q,TE,DI,ZE,RQ,SL,SI,GZ,Z00,N1) C-DBG print *,' main twrite ' CALL ROWSEP(GESHEM) WRITE(NSIGS)GESHEM CALL ROW1NS(GESHEM) CLOSE(NSIGS) CALL GLOOPZ(NZNLS,NSFCS) C-DBG print *,' gmain loopz ' ENDIF C................................................ C RSM : CALL MAIN ROUTINE OF REGIONAL FORECAST C-RSM CALL RSMSMF(FHOUR,SHOUR,GZ,Q,TE,DI,ZE,RQ) C 10000 CONTINUE C CALL GLOOPP(Q,AVPRS0) C C-DBG print *,' time loop ended ' C................................................ C... TIME LOOP C................................................ PRINT *,' PREDICTED FULL VALUES AT THE END OF FORECST SEGMENT' CALL RMSGT(Q,DI,TE,ZE,DEL,RQ) PRINT 102,DELTIM,CHOUR 102 FORMAT(1H0,'STEP=',E10.2,2X,'FCST SEGMENT OF ',E10.2,' H') CALL TWRITE(N4,THOUR,IDATE,Z,Q,TE,DI,ZE,RQ,SL,SI,GZ,Z00,N1) C-DBG print *,' main twrite ' CALL ROWSEP(GESHEM) WRITE(N4)GESHEM CALL ROW1NS(GESHEM) CLOSE(N4) IHOUR=THOUR+0.5 E 0 MOD12=MOD(IHOUR,12) PRINT 107,MOD12 107 FORMAT(1H ,'MOD12=',I2) LIMLOW=1 IF(NPOINT.GT.0) THEN C... NOTE, THAT IN SEVERAL SCENERIOS, ITNUM=ITNUM+1 AT THE C BOTTOM OF THE 10000 LOOP, SO UNDO IT IF (IKFREQ.GT.1) THEN IF (IMODK.LE.0) THEN ITNUM = ITNUM - 1 END IF ELSE ITNUM = ITNUM - 1 END IF PRINT 1047,ITNUM,NPOINT 1047 FORMAT(1H0,I6,' STEPS OF KEN(CAMPANA) GRIDPT DATA SAVED FOR ', 1 I5,' POINTS') C... NOTE : NOTHING SPECIAL DONE FOR OUTBOARD RADIATION (IBRAD NE 1) C IN THIS CASE, TO GET THE RADIATION,CLDS INTO KEN PTS, C SOME WORK NEEDS TO BE DONE IN GETRAD....K.A.C. DO 730 J=1,NPOINT DO 730 K=1,ITNUM C... IF OLR.LE ZERO,THEN RADIATION FIELDS HAVE NOT BEEN FILLED C FOR THIS TIMESTEP, SO CARRY THE PREVIOUS DATA FORWARD IF (SVDATA(44,J,K).LE.0.) THEN DO I=25,27 SVDATA(I,J,K)= SVDATA(I,J,K-1) ENDDO DO I=41,46 SVDATA(I,J,K)= SVDATA(I,J,K-1) ENDDO DO I = 48, 49 SVDATA(I,J,K)= SVDATA(I,J,K-1) ENDDO DO I = 51, 58 SVDATA(I,J,K)= SVDATA(I,J,K-1) ENDDO I=38 SVDATA(I,J,K)= SVDATA(I,J,K-1) DO LV=1, 28 SVDATA(LV+ 80 +( 8 -1)* 28 ,J,K)= 1 SVDATA(LV+ 80 +( 8 -1)* 28 ,J,K-1) ENDDO ENDIF IF (SVDATA(50,J,K).LE.0.) THEN I=47 SVDATA(I,J,K)= SVDATA(I,J,K-1) I=50 SVDATA(I,J,K)= SVDATA(I,J,K-1) END IF IF (SVDATA(70,J,K).LE.0.) THEN DO I = 70, 74 SVDATA(I,J,K)= SVDATA(I,J,K-1) ENDDO ENDIF 730 CONTINUE WRITE(NGPKEN) LAB WRITE(NGPKEN) FHOUR,IDATE,SI,SL WRITE(NGPKEN) NVRKEN,NPTKEN,NSTKEN,NPOINT,ITNUM DO 333 J=1,NPOINT WRITE(NGPKEN) ((SVDATA(I,J,K),K=1,ITNUM),I=1,NVRKEN) 333 CONTINUE CLOSE(NGPKEN) ENDIF 20000 CONTINUE C-CRA TSTEP=TIMEF()*0.001-TSTEP0 C-CRA NSTEPS=ISTEPS*(MAXSTP-LIMLOW+1) C-CRA PRINT*,' TIME, STEPS, TIME PER STEP: ',TSTEP,NSTEPS,TSTEP/NSTEPS C CALL GLOOPP(QM,AVPRS0) C CALL TWRITE(N3,THOUR,IDATE,Z,QM,TEM,DIM,ZEM,RM,SL,SI,GZ,Z00,N1) C-DBG print *,' main twrite ' CALL ROWSEP(GESHEM) WRITE(N3)GESHEM CALL ROW1NS(GESHEM) CLOSE(N3) C CREATE SPECIAL DIAGNOSTIC FIELDS INISTP = 3 CALL GLOOPZ(NZNLF,NSFCF) C-DBG print *,' main gloopz ' C... WRITE FIXED FIELDS FOR RADIATION PROG. TO DISK... CALL FIXIO(THOUR,TSEA,SMC,SHELEG,STC,TG3,ZORL,PLANTR, 1 CV,CVB,CVT,ALBEDO,SLMSK,F10M,CANOPY,1,NFLIP,NFLOP) C-DBG print *,' main fixio ' C CALL WRIDIA (FHOUR,RHOUR,IDATE,SL,COLRAB,SLMSK, 1 TSEA,SMC,SHELEG,STC,TG3,CANOPY, 1 ZORL,GESHEM,BENGSH,DUSFC,DVSFC,DTSFC,DQSFC, 1 FLUXR,CVAVG,ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 1 NDGF) C C-LFM CALL LFMFOUT(IFSTEP,THOUR,N1) C C RSM .................. SAVE RSM OUT................. C-RSM CALL RSMSAV(FHOUR) C.................................................... CCCRA CALL W3LOG('$E') STOP END SUBROUTINE STEP1(N1,N2,ITREAD,INI,NANL,SOLSEC) C.... C................................................................. C................BEGIN TWOLOOP(COMFIBM)........................ C.... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.................SOF TWOLOOP(COMFIBM)........................ C................................................................ C...SOF INCLUDE.......................................... C FORECAST SELECTION PARAMETERS COMMON/COMCON/ CON(1700),NUM(1700) DIMENSION IDSAVE(4) PRINT 9876,N1,N2,ITREAD,FHOUR 9876 FORMAT(1H ,'N1,N2,ITREAD,FHOUR IN STEP1',3(I4,1X),F6.2) IF(ITREAD.EQ.0)GO TO 2000 CALL TREAD(N1,FHOUR,IDATE,GZ,QM,TEM,DIM,ZEM,RM,SL,SI,Z00) REWIND N1 PRINT 9877,N1,ITREAD,FHOUR 9877 FORMAT(1H ,'N1,ITREAD,FHOUR AFTER TREAD',2(I4,1X),F6.2) PRINT *,' INPUT T=T0 FULL VALUES' CALL RMSGT(QM,DIM,TEM,ZEM,DEL,RM) CALL TREAD(N2,FHOUR,IDATE,GZ,Q,TE,DI,ZE,RQ,SL,SI,Z00) REWIND N2 PRINT 9878,N2,ITREAD,FHOUR 9878 FORMAT(1H ,'N2,ITREAD,FHOUR AFTER TREAD',2(I4,1X),F6.2) PRINT *,' INPUT T=T0+DT FULL VALUES' CALL RMSGT(Q,DI,TE,ZE,DEL,RQ) C SET INITIAL SOLHR SOLHR=FHOUR+IDATE(1) IDAY=SOLHR/24. E 0 SOLHR=SOLHR-IDAY*24. E 0 SOLSEC=SOLHR*3600. 2000 CONTINUE C............................................................ C............................................................ DO 22000 L=1, 47 DO 22000 J=1, 384 GESHEM(J,L)=0. E 0 TMPMAX(J,L) = 0. TMPMIN(J,L) = 1.E10 22000 CONTINUE C.. C....READ FIXED FIELDS FROM FIXFLD PROG............ C.. CALL FIXIO(FHOUR,TSEA,SMC,SHELEG,STC,TG3,ZORL,PLANTR, & CV,CVB,CVT,ALBEDO,SLMSK,F10M,CANOPY,0,NFLIP,NFLOP) C .............................................................. CALL ZERFLX(DUSFC,DVSFC,DTSFC,DQSFC,DLWSFC,ULWSFC, 1 BENGSH,GFLUX,RUNOFF,EP,CLDWRK, 2 DUGWD,DVGWD,PSMEAN,SNOWFALL,SNOWEVAP,SNOWMELT) C .............................................................. C... FIRST STEP IS FORWARD. THEN 2 LEAPFROGS, DOUBLING DELTIM. C .............................................................. SHOUR=0. IF(FHOUR.NE.0.0.AND.INI.EQ.0) RETURN NFSTEP=2 DELTIM=CON(1)/2. E 0**2 INISTP=1 ISAVE=1 IF(ITREAD.EQ.1) THEN IF(N1.EQ.N2 .AND. N2.NE.NANL) THEN SAVFHR=FHOUR C-CRA IDSAVE=IDATE C-CRA Z=Q C-CRA W=TE C-CRA X=DI C-CRA Y=ZE C-CRA RT=RQ DO I=1,4 IDSAVE(I)=IDATE(I) ENDDO DO I=1, 4033 Z(I)=Q(I) ENDDO DO K=1, 28 DO I=1, 4033 W(I,K)=TE(I,K) X(I,K)=DI(I,K) Y(I,K)=ZE(I,K) RT(I,K)=RQ(I,K) ENDDO ENDDO REWIND NANL CALL TREAD(NANL,FHOUR,IDATE,GZ,Q,TE,DI,ZE,RQ,SL,SI,Z00) REWIND NANL ENDIF CALL GLOOPR C-DBG print *,' step1 gloopr ' IF(N1.EQ.N2 .AND. N2.NE.NANL) THEN FHOUR=SAVFHR C-CRA IDATE=IDSAVE C-CRA Q=Z C-CRA TE=W C-CRA DI=X C-CRA ZE=Y C-CRA RQ=RT DO I=1,4 IDATE(I)=IDSAVE(I) ENDDO DO I=1, 4033 Q(I)=Z(I) ENDDO DO K=1, 28 DO I=1, 4033 TE(I,K)=W(I,K) DI(I,K)=X(I,K) ZE(I,K)=Y(I,K) RQ(I,K)=RT(I,K) ENDDO ENDDO ENDIF ENDIF C-LFM CALL LFMFINI(IPSTEP,FHOUR) C-LFM ICSTEP=NINT(FHOUR*3600./DELTIM)+1 C-LFM WRITE(6,*) 'IPSTEP FROM LFMFINI IN STEP1=',IPSTEP C-LFM WRITE(6,*) 'ICSTEP COMPUTED FROM FHOUR=',ICSTEP SHOUR=SHOUR+DELTIM DO 5000 JDT=1,2 IF (JDT.GT.1) INISTP=0 IF (JDT.GT.1) ISAVE = 0 KDT=JDT PRINT 102,KDT 102 FORMAT(1H ,'KDT IN FIRST STEP=',I6) LASTEP=KDT.EQ.2 SHOUR=SHOUR+DELTIM CALL GSICDF(DELTIM,AM,BM,GV,SV,CM) C-DBG print *,' step1 gsicdf ' CALL GLOOPA C-DBG print *,' step1 gloopa ' CALL SICDIF(DIM,TEM,QM,X,Y,Z,ULN,VLN) C-DBG print *,' step1 sicdif ' C-DBG call flush(6) CALL DELDIF(RT,W,DELTIM,QM,SL,X,Y) C-DBG print *,' step1 deldif ' PRINT *,' PREDICTED FULL BY GLOOPA, SEMIMP and DELDIF' CALL RMSGT(Z ,X ,Y ,W ,DEL,RT) DO 3 J=1, 4032 Q(J)=Z(J) 3 CONTINUE CALL GLOOPB C-DBG print *,' step1 gloopb ' PRINT *,' GLOOPB PREDICTED FULL VALUES' CALL RMSGT( Q, X, Y, W,DEL,RT) CALL DAMPUX(X,W,Y,RT,DELTIM,ULN,VLN,SPDMAX) C-DBG print *,' step1 dampux ' DO 5 K=1, 28 DO 4 J=1, 4032 DI(J,K)=X(J,K) ZE(J,K)=W(J,K) TE(J,K)=Y(J,K) 4 CONTINUE 5 CONTINUE DO 7 K=1, 28 DO 8 J=1, 4032 RQ(J,K)=RT(J,K) 8 CONTINUE 7 CONTINUE DELTIM=DELTIM*2. E 0 PRINT *,' FULLY PREDICTED FULL VALUES' CALL RMSGT( Q, DI, TE, ZE,DEL,RQ) 5000 CONTINUE C-LFM IFSTEP=2 C-LFM CALL LFMFILT(IFSTEP,FHOUR) SOLSEC=SOLSEC+DELTIM SOLHR=SOLSEC/3600. E 0 C............................................................... C... FIN SMOOTH START C............................................................... DELTIM=CON(1) LIMLOW=2 RETURN END SUBROUTINE ZERFLX(DUSFC,DVSFC,DTSFC,DQSFC,DLWSFC,ULWSFC, 1 BENGSH,GFLUX,RUNOFF,EP,CLDWRK, 2 DUGWD,DVGWD,PSMEAN,SNOWFALL,SNOWEVAP,SNOWMELT) DIMENSION DUSFC( 384 , 47 ),DVSFC( 384 , 47 ) DIMENSION DTSFC( 384 , 47 ),DQSFC( 384 , 47 ) DIMENSION DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ) DIMENSION BENGSH( 384 , 47 ),GFLUX( 384 , 47 ) DIMENSION RUNOFF( 384 , 47 ),EP( 384 , 47 ) DIMENSION CLDWRK( 384 , 47 ) DIMENSION DUGWD( 384 , 47 ),DVGWD( 384 , 47 ) DIMENSION PSMEAN( 384 , 47 ) DIMENSION SNOWFALL( 384 , 47 ) DIMENSION SNOWEVAP( 384 , 47 ) DIMENSION SNOWMELT( 384 , 47 ) DO 23500 L=1, 47 DO 23500 J=1, 384 DUSFC(J,L)=0. E 0 DVSFC(J,L)=0. E 0 DTSFC(J,L)=0. E 0 DQSFC(J,L)=0. E 0 DLWSFC(J,L)=0. E 0 ULWSFC(J,L)=0. E 0 BENGSH(J,L)=0. E 0 GFLUX(J,L)=0. E 0 RUNOFF(J,L) = 0. E 0 EP(J,L) = 0. E 0 CLDWRK(J,L) = 0. E 0 DUGWD(J,L)=0. E 0 DVGWD(J,L)=0. E 0 PSMEAN(J,L)=0. E 0 SNOWFALL(J,L)=0. E 0 SNOWEVAP(J,L)=0. E 0 SNOWMELT(J,L)=0. E 0 23500 CONTINUE C-------------------------------------------------------------- RETURN END SUBROUTINE MLTFLX(FAC,DUSFC,DVSFC,DTSFC,DQSFC,DLWSFC,ULWSFC, 1 BENGSH,GFLUX, 2 DUGWD,DVGWD,PSMEAN) DIMENSION DUSFC( 384 , 47 ),DVSFC( 384 , 47 ) DIMENSION DTSFC( 384 , 47 ),DQSFC( 384 , 47 ) DIMENSION DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ) DIMENSION BENGSH( 384 , 47 ),GFLUX( 384 , 47 ) DIMENSION DUGWD( 384 , 47 ),DVGWD( 384 , 47 ) DIMENSION PSMEAN( 384 , 47 ) DO 23500 L=1, 47 DO 23500 J=1, 384 DUSFC(J,L)=FAC*DUSFC(J,L) DVSFC(J,L)=FAC*DVSFC(J,L) DTSFC(J,L)=FAC*DTSFC(J,L) DQSFC(J,L)=FAC*DQSFC(J,L) DLWSFC(J,L)=FAC*DLWSFC(J,L) ULWSFC(J,L)=FAC*ULWSFC(J,L) BENGSH(J,L)=FAC*BENGSH(J,L) GFLUX(J,L)=FAC*GFLUX(J,L) DUGWD(J,L)=FAC*DUGWD(J,L) DVGWD(J,L)=FAC*DVGWD(J,L) PSMEAN(J,L)=FAC*PSMEAN(J,L) 23500 CONTINUE C-------------------------------------------------------------- RETURN END SUBROUTINE GETCON(N1,N2,NGES,NRADR,NRADF,NNMOD, 1 N3,N4,NFLPS,NSIGI,NSIGS,NSFCI,NZNLI,NSFCF,NZNLF,NSFCS,NZNLS, 2 NDGI,NDGF,NGPKEN, 3 MODS,NITER,INI,NSTEP,NFILES, C-RSM3 NRSMI1,NRSMI2,NRFLIP, C-RSM& NRSMO1,NRSMO2,NRFLOP,NRSFLI,NRSFLX,NRINIT,NRPKEN, C-LFM& NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO,KLENP,WEIGHT,FWINDOW, 4 KSOUT,IFGES,IBRAD) C.... C................................................................. C................BEGIN TWOLOOP(COMFIBM)........................ C.... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.................SOF TWOLOOP(COMFIBM)........................ C................................................................ C FORECAST SELECTION PARAMETERS COMMON/COMCON/ CON(1700),NUM(1700) PARAMETER(NVRKEN= 80 + 8 * 28 ,NPTKEN= 30 ) PARAMETER(NSTKEN= 48 ) COMMON/COMGPD/ SVDATA(NVRKEN,NPTKEN,NSTKEN), 1 IGRD(NPTKEN),JGRD(NPTKEN), 2 IGRDR(NPTKEN),JGRDR(NPTKEN), 3 ITNUM,NPOINT,ISAVE,ISSHRT,ILSHRT,IKFREQ C C-LFM DIMENSION WEIGHT(*) C-LFM DIMENSION WEIX(1000) C C-WAV COMMON/COMWAV/ HSTR,USTRGG( 384 , 47 ),VSTRGG( 384 , 47 ) NAMELIST/NAMSMF/ CON,NUM,LABL,ENDHOUR,LDEBUG,FILTA,ICEN,IGEN,ICEN2 & ,IENST,IENSI,RUNID,USRID,NCPUS C-LFM& ,CRITFS,FILTWIN LIMLOW=1 JCAP= 62 LEVS= 28 FILTA= 0.92 DT80=939.14 E 0 MODS=4 NITER=2 PERCUT=27502. E 0 ICEN=7 IGEN= 80 ICEN2=0 IENST=0 IENSI=0 RUNID=0 USRID=0 CALL GNCPUS(NCPUS) C.......................................... C C DEFINE UNIT NUMBERS C C INPUT N1 = 11 N2 = 12 NGES = 13 NFLIP = 14 NRADR = 21 NRADF = 22 NNMOD = 23 NMTNV = 24 C-LFM NLFMSGI=30 C-LFM NLFMSFI=31 C-RSM NRSMI1= 30 C-RSM NRSMI2= 31 C-RSM NRFLIP= 32 C OUTPUT N3 = 51 N4 = 52 NFLOP = 53 NFLPS = 54 NSIGI = 55 NSIGS = 56 NZNLI = 61 NSFCI = 62 NSFCF = 63 NZNLF = 64 NDGI = 65 NDGF = 66 NGPKEN= 67 NSFCS = 68 NZNLS = 69 C-LFM NLFMSGO= 70 C-LFM NLFMSFO= 71 C-RSM NRSMO1= 70 C-RSM NRSMO2= 71 C-RSM NRFLOP= 72 C-RSM NRSFLX= 73 C-RSM NRSFLI= 74 C-RSM NRPKEN= 77 C-RSM NRINIT= 78 C WORK FILES NR2DDA = 98 C.... C.... CMEAN,CLSTP CONTROL TIME AVERAGING OF CONVECTIVE CLDS IN KUO C.... CLSTP=99. C.... C... AVERAGING INTERVAL FOR CONV CLD APPROX 3 HRS (NUM OF TIMESTEPS) C.... READ(NMTNV) HPRIME call maxmin(hprime, 384 , 47 , 384 , 47 ,1) CALL ROW1NS(HPRIME) PRINT 100, JCAP, LEVS 100 FORMAT (1H0,'GETCON ',I3,I3,'CREATED APRIL 92') FILTB =(1. E 0-FILTA) * 0.5 E 0 CALL SETSIG(CI,SI,DEL,SL,CL,RPI,N1) SL1=SL(1) DO 3 LEV=1, 28 TOV(LEV)=300. E 0 3 CONTINUE CALL AMBMSV( 28 ,SI,SL,TOV,AM,BM,SV,GV,CM) CALL GLATS( 47 , COLRAD, WGT, WGTCS, RCS2) CALL GLATS( 47 , COLRAB, WGB, WGBCS, RBS2) CALL EPSLON(EPS, 62 ) C C RPI(K) = (SL(K+1)/SL(K))**RK FROM SETSIG K=1... 27 C DO 9 K=1, 27 RPIREC(K) = 1. E 0/RPI(K) 9 CONTINUE DO 10 K=1, 28 RDEL2(K)=0.5 E 0/DEL(K) 10 CONTINUE IND=0 DO 7 LL=1, 63 N=LL-2 MAXI= 63 +1-LL DO 6 I=1,MAXI IND=IND+1 N=N+1 NDEX(IND*2-1) = N NDEX(IND*2 ) = N FACT=FLOAT(N*(N+1)) SNNP1(IND*2-1) = FACT SNNP1(IND*2 ) = FACT 6 CONTINUE 7 CONTINUE DLON = 2. E 0 * 3.141593E+0 / 192 . E 0 DO 20 J=1, 47 DO 20 I=1, 192 XLON(I,J) = DLON * (I-1) XLON(I+ 192 ,J) = XLON(I,J) 20 CONTINUE DO 25 J=1, 47 SINLAT(J) = COS(COLRAD(J)) 25 CONTINUE DO 30 J=1, 47 SINLAJ = COS(COLRAB(J)) COSLAJ = SQRT(1. E 0 - SINLAJ*SINLAJ) DO 30 I=1, 192 SINLAB(I,J) = SINLAJ COSLAB(I,J) = COSLAJ SINLAB(I+ 192 ,J) = -SINLAJ COSLAB(I+ 192 ,J) = COSLAJ 30 CONTINUE C INITIALIZE CV, CVT AND CVB DO 40 J=1, 47 DO 40 I=1, 384 CV (I,J) = 0. E 0 CVT(I,J) = 0. E 0 CVB(I,J) = 100. E 0 40 CONTINUE C DO 1 I=1,28 1 NUM(I)=0 NUM( 1) = 11 NUM( 2) = 11 NUM( 3) = 51 NUM( 4) = 52 NUM( 5) = 0 NUM( 6) = 1 NUM( 7) = 0 NUM( 8) = 1 NUM( 9) = 8 NUM(10) = 15 NUM(11) = 1 NUM(12) = 23 NUM(13) = 1 NUM(14) = 55 NUM(15) = 0 NUM(16) = 11 NUM(17) = 51 NUM(18) = 4 NUM(19) = 2 NUM(20) = 6 NUM(21) = 15 NUM(22) = 10 NUM(23) = 1 NUM(24) = 0 NUM(25) = 0 NUM(26) = 0 NUM(27) = 0 NUM(28) = 0 CTEMPORARILY SET SOME CONS AND NUMS (SETC BLOCK DATA NOT YET INCLUDED) NUM(1)=0 CON(1)=0. CON(3)=0. ! GSM DFINI INITIALIZATION IN HOUR OR NOT (0.) C HMHJ CON(4)=1. ! DTSWAV IN HOUR FOR GSM C HMHJ CON(5)=3. ! DTLWAV IN HOUR FOR GSM CON(6)=0. CON(7)=12. C-WAV CON(10)=0. C-RSM CON(11)=400. ! RSM DELTIM C-RSM CON(12)=21600. ! RSM NESTING PERIOD IN SECOND C-RSM CON(13)=6.0 ! RSM INITIALIZATION STEP IN HOUR OR NOT (0.) C-RSM CON(14)=1. ! RSM DTSWAV IN HOUR C-RSM CON(15)=1. ! RSM DTLWAV IN HOUR C-RSM CON(16)=0. ! RSM START FORECAST PERIOD C-RSM CON(17)=36. ! RSM ENDING FORECAST PERIOD C-RSM CON(18)=0. ! RSM local diffusion (1) or not (0) C-RSM CON(19)=0. ! RSM lateral boundary relaxation 1 blending 0 NUM(31)=1 NUM(32)=0 NUM(30)=0 ENDHOUR=0. READ(5,NAMSMF,END=199) GOTO 202 CTEMPORARILY READ FROM ORIGINAL INPUT CARD IF NAMELIST IS MISSING 199 CONTINUE REWIND 5 READ(5,200)(NUM(I),I=1,28) 200 FORMAT(28I2) 202 CONTINUE C C TEMPORARILY RESET SOME CONS AND NUMS C READ(N1) READ(N1) FHOUR REWIND N1 IF(FHOUR.EQ.0.) THEN IF(NUM(5).EQ.-1) NUM(5)=2 IF(NUM(5).EQ.-2) NUM(5)=1 ELSE IF(NUM(5).EQ.-1) NUM(5)=0 IF(NUM(5).EQ.-2) NUM(5)=0 ENDIF IF(CON(1).LE.0.) CON(1)=DT80 *80./JCAP IF(NUM(7).LE.0) THEN NUM(7)=3600.*CON(7)/CON(1)+0.99 CON(1)=NINT(3600.*CON(7)/NUM(7)) ELSE CON(7)=NUM(7)*CON(1)/3600. ENDIF IF(NUM(32).EQ.0) NUM(32)=NUM(7) IF(NUM(1).GT.0) CON(6)=NUM(1) C C.... C.... DTSWAV IS INTERVAL BETWEEN SHORT-WAVE HEATING CALCULATIONS C.... DTLWAV IS INTERVAL BETWEEN LONG-WAVE HEATING CALCULATIONS C.... DTSWAV=CON(4) DTLWAV=CON(5) C C CHECK DTSWAV AND DTLWAV IF THEY ARE REASONABLE C IF(MOD(INT(DTSWAV*3600.),INT(CON(1))).NE.0) THEN PRINT *,'DTSWAV MUST BE A MULTIPLE OF TIMESTEP' CALL ABORT ENDIF IF(MOD(24*60,INT(DTSWAV*60.)).NE.0) THEN PRINT *,'24*60 MUST BE MUST BE A MULTIPLE OF DTSWAV*60' CALL ABORT ENDIF IF(MOD(INT(DTLWAV*3600.),INT(CON(1))).NE.0) THEN PRINT *,'DTLWAV MUST BE A MULTIPLE OF TIMESTEP' CALL ABORT ENDIF IF(MOD(24*60,INT(DTLWAV*60.)).NE.0) THEN PRINT *,'24*60 MUST BE MUST BE A MULTIPLE OF DTLWAV*60' CALL ABORT ENDIF C COWAVE=0. DTWAVE=0. C-WAV COWAVE=CON(10) C-WAV DTWAVE=ABS(CON(10)) C C>YH CVMINT - MAXIMUM CONV. CLD ACCUMULATION TIME INTERVAL IN HOURS C.... CURRENTLY HARDWIRED AS 3 HOURS, BUT MAY BE AS AN C.... INPUT VARIABLE. C CVMINT = 3. E 0 CVMINT = CON(4) DTCVAV = MIN (CVMINT, MAX (DTSWAV,DTLWAV)) C PRINT 201,(NUM(I),I=1,28) 201 FORMAT(1H0,'NUM=',28(1X,I2)) PRINT *,'CON' PRINT *,(CON(I),I=1,10) C IF(CON(6).GT.0) THEN KSOUT=3600.*CON(6)/CON(1)+0.5 ELSE KSOUT=0 ENDIF C IF(NUM(18).NE.0)MODS=NUM(18) IF(NUM(19).NE.0)NITER=NUM(19) INI=NUM(5) C TEST IF A GUESS FILE IS AVAILABLE (IF SO ,SET IFGES=1) IFGES=0 IF(INI.NE.0) THEN REWIND NGES READ(NGES,END=6782) IFGES=1 6782 CONTINUE REWIND NGES ENDIF IBRAD=1 REWIND NRADR READ(NRADR,END=6792) IBRAD=0 6792 CONTINUE REWIND NRADR NSTEP=NUM(6) IF(NSTEP.EQ.1)NSTEP=7 NFILES=NUM(11) DK=NUM(9) DK=DK*(10. E 0)**NUM(10) TK=NUM(20) TK=TK*(10. E 0)**NUM(21) IF(NUM(20).EQ.0)TK=DK PRINT 105,CON(1),FILTA,DK,TK 105 FORMAT(1H ,5X,F5.0,1X,F4.2,1X,E8.2,1X,E8.2) NPOINT=NUM(1300) IF(NPOINT.LT.0.OR.NPOINT.GT.NPTKEN) THEN PRINT *,'KEN POINTS DISABLED - GRID POINTS EXCEED ',NPTKEN NPOINT=0 ENDIF ISAVE=0 ITNUM=0 IF(NPOINT.NE.0) THEN ISAVE=1 ITNUM=1 ISSHRT=NUM(1301) ILSHRT=NUM(1302) IKFREQ=NUM(1303) CALL KENPRE(CON,COLRAD, 192 , 47 ,NFLIP) ENDIF N50UFL=NUM(30) NCPUS1=NCPUS+1 NCLDB1=NCPUS* 384 / 384 +1 CC CC CALL CMPIND TO SET COMMON/COMIND/ FOR SUBS. TRANSI,TRANSO. CALL CMPIND C-DBG print *,' cmpind ' CC CALL GPVS C-DBG print *,' gpvs ' CALL GTDP C-DBG print *,' gtdp ' CALL GTHE C-DBG print *,' gthe ' CALL GTMA C-DBG print *,' gtma ' CALL GPLN2I C-DBG print *,' gpln2i ' CALL EPSILO(EPSI, 62 ) C-DBG print *,' epsilo ' CALL GGOZRM(EPSI) C-DBG print *,' ggozrm ' CALL GFT_LONF C-DBG print *,' gft_lonf ' CALL GFT_LONB C-DBG print *,' gft_lonb ' CALL GRDDF C-DBG print *,' grddf ' CALL GRDKT C-DBG print *,' grdkt ' C C FILTWIN in the unit of hour C C-LFM SECHR=60.*60. C-LFM KLENP=NINT(FILTWIN*SECHR/CON(1))+1 C-LFM NLENP=(KLENP-1)/2+1 C-LFM CRITFL=9.0E10 C-LFM CLANCZ=1.0 C-LFM TINC=CON(1) C-LFM CRITSC=CRITFS*SECHR C-LFM WRITE(6,*) 'KLENP,NLENP,TINC,CRITFS,CRITSC,CRITFL,CLANCZ=', C-LFM1 KLENP,NLENP,TINC,CRITFS,CRITSC,CRITFL,CLANCZ C-LFM CALL FILTCOF(NLENP,TINC,CRITSC,CRITFL,CLANCZ,WEIX) C-LFM FWINDOW=FILTWIN C C Expand weights C C-LFM WEIGHT(NLENP)=WEIX(1) C-LFM DO K=2,NLENP C-LFM WEIGHT(NLENP+K-1)=WEIX(K) C-LFM WEIGHT(NLENP-K+1)=WEIX(K) C-LFM ENDDO C-LFM DO K=1,KLENP C-LFM PRINT *,K,' WEIGHT=',WEIGHT(K) C-LFM ENDDO C RETURN END C----------------------------------------------------------------------- SUBROUTINE GNCPUS(NCPUS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GNCPUS GETS ENVIRONMENT NUMBER OF CPUS C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-08-19 C C ABSTRACT: GETS AND RETURNS THE ENVIRONMENT VARIABLE NCPUS, C DESIGNATING THE NUMBER OF PROCESSORS OVER WHICH TO PARALLELIZE. C C PROGRAM HISTORY LOG: C 94-08-19 IREDELL C C USAGE: CALL GNCPUS(NCPUS) C OUTPUT ARGUMENTS: C NCPUS INTEGER NUMBER OF CPUS C C SUBPROGRAMS CALLED: C get_environment_variable GET ENVIRONMENT VARIABLE C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C C$$$ INTEGER get_environment_variable CHARACTER*8 CNCPUS C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NCPUS= 1 C-T90 IF(1.NE.1) THEN C-CRA callget_environment_variable('NCPUS',CNCPUS,status=iret) C-T90 ELSE C-T90 IRET=0 C-T90 CALL PXFGETENV('NCPUS',5,CNCPUS,LINVAL,JRET) C-T90 IF(JRET.EQ.0) IRET=1 C-T90 ENDIF C-CRA IF(IRET.EQ.1) THEN C-CRA READ(CNCPUS,'(BN,I8)',IOSTAT=IOS) NCPUS C-CRA NCPUS=MAX(NCPUS,1) C-CRA PRINT *,'NCPUS=',NCPUS C-CRA ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END SUBROUTINE ZONZER(FLN) DIMENSION FLN(2, 2016 ) INC= 63 I=1 DO 1 LL=1, 63 C PRINT 100,I,INC C100 FORMAT(1H ,'I INC ',I4,2X,I4) FLN(2,I)=0. I=I+INC INC=INC-1 1 CONTINUE RETURN END SUBROUTINE KENPRE(CON,COLRAD,IDIM,JDIM2,NFLX) C.... C THIS ROUTINE COMPUTES THE KENDATA GRID POINT INDICES IGRD,JGRD FOR C FCST GRID AND IGRDR,JGRDR FOR RADIATION GRID, FOR THE C NPOINT POINTS,GIVEN THE LONGITUDE AND LATITUDE OF SAME (CON). C COLRAD IS THE COLATITUDE OF THE FCST GRID (DIMENSIONED JDIM2,WHICH C IS HALF OF THE TOTAL LATITUDINAL GRID POINTS), C.... PARAMETER(NVRKEN= 80 + 8 * 28 ,NPTKEN= 30 ) PARAMETER(NSTKEN= 48 ) COMMON/COMGPD/ SVDATA(NVRKEN,NPTKEN,NSTKEN), 1 IGRD(NPTKEN),JGRD(NPTKEN), 2 IGRDR(NPTKEN),JGRDR(NPTKEN), 3 ITNUM,NPOINT,ISAVE,ISSHRT,ILSHRT,IKFREQ DIMENSION COLRAD(JDIM2),CON(1700) DIMENSION ALAT(NPTKEN),ALON(NPTKEN),KPOI(NPTKEN) DIMENSION SLIMSK( 192 , 94 ),BLATF( 94 ),BLATR( 94 ) DIMENSION COLRAR( 47 ),WGR( 47 ),WGRCS( 47 ),RRS2( 47 ) DATA PI/ 3.141593E+0 / C.... BEGIN HERE.. DO 2 K=1,NSTKEN DO 2 J=1,NPTKEN DO 2 I=1,NVRKEN SVDATA(I,J,K) = 0. 2 CONTINUE C--- GET SLMSK BECAUSE WE WISH TO GET NEAREST POINT C OF SAME SFC TYPE...THIS ARRAY NOT AVAILABLE TIL AFTER STEP1 C IF WE WERE NOT TRYING TO COVER OURSELVES FOR OUT-BOARD RADI8 C ,THEN THIS CODE COULD BE CALLED FROM STEP1... REWIND NFLX READ(NFLX) READ(NFLX) GHOUR,ID1,ID2,ID3,ID4 99 FORMAT(1H ,'FHOUR, IDATE=',F6.2,2X,4(1X,I4)) PRINT *,'IN KENPRE READ SLMSK FROM UNIT=',NFLX PRINT 99,GHOUR, ID1,ID2,ID3,ID4 READ(NFLX) READ(NFLX) READ(NFLX) READ(NFLX) READ(NFLX) READ(NFLX) C..... SKIP CV, CVB, CVT, ALBEDO READ(NFLX) READ(NFLX) READ(NFLX) READ(NFLX) READ(NFLX) SLIMSK REWIND NFLX CCCC CALL ROW1NS(SLIMSK) CALL GLATS ( 47 , COLRAR, WGR, WGRCS, RRS2) DXF = 360. / 192 DXR = 360. / 192 ILONF = 192 ILONR = 192 JLATG2 = 47 JLATR2 = 47 JLATG = 94 JLATR = 94 JFP1 = JLATG2 + 1 JRP1 = JLATR2 + 1 C---- GET LATITUDE OF GAUSSIAN GRIDS DO 3 J=1,JLATG2 BLATF(J) =(PI /2. - COLRAD(J)) * 180. / PI 3 CONTINUE BLATF(JFP1) = -BLATF(JLATG2) DO 4 J=1,JLATR2 BLATR(J) =(PI /2. - COLRAR(J)) * 180. / PI 4 CONTINUE BLATR(JRP1) = -BLATR(JLATR2) C... PUT LAT/LON INTO USEABLE ARRAYS (MAX=200),WHERE C NPOINT GT 0 IMPLIES NPOINT LAT/LON S IN CON AND C IF ABS(LAT) BETWEEN 0, 90 LOOK FOR NEAREST POINT C BETWEEN 100,190 LOOK FOR NEAREST LAND POINT C BETWEEN 200,290 LOOK FOR NEAREST SEA POINT C NPOINT LT 0 IMPLIES LAT/LON OF CENTER OF REGION ,ONLY.. C LAT,LON=CON(1301),CON(1501) C LET XY=ABS(NPOINT) AND ALWAYS BE 2 DIGITS C AND DO NOT DIFFERENTIATE LAND/SEA, C THEN X BETWEEN 1,9 MEANS CREATE ARRAY OF EVERY X POINTS C (I.E. X=1 MEANS EVERY POINT,X=3 MEANS EVERY 3RD,.. C AND Y BETWEEN 0,9 MEANS CREATE (Y+1,Y+1) ARRAY.. C THUS XY CAN HAVE VALUES 10-99 C.... NPUTE = -1 IF (NPOINT.LT.0) THEN XY = ABS(NPOINT) IF (XY.LT.10..OR.XY.GT.99.) THEN NPUTE = 0 PRINT 98,NPOINT 98 FORMAT(1H ,' NUM(1300)=',I6,'OUT OF -RANGE, SO SET=1') NPOINT = 1 ELSE NPOINT = 1 ISKP = XY/10 IY = XY - ISKP*10 + 1 PRINT 97,IY,IY,ISKP 97 FORMAT(1H ,' PREPARE REGIONAL (',I2,',',I2,') ARRAY - EVERY', 1 I2,' POINTS') NPUTE = IY * IY END IF END IF DO 5 K = 1, NPOINT ILS = -1 YLAT = ABS(CON(K+1300)) IF (YLAT.GE.100.AND.YLAT.LE.190.) THEN C... LAND POINT IS DESIRED... ILS = 1 SGN = CON(K+1300) / YLAT CON(K+1300) = YLAT-100. IF (SGN.LT.0.) CON(K+1300) = - (YLAT-100.) END IF IF (YLAT.GE.200.AND.YLAT.LE.290.) THEN ILS = 0 SGN = CON(K+1300) / YLAT CON(K+1300) = YLAT-200. IF (SGN.LT.0.) CON(K+1300) = - (YLAT-200.) END IF XLAT = CON(K+1300) XLON = CON(K+1500) IF (NPUTE.LT.0.AND.ILS.EQ.-1) PRINT 197,K,XLAT,XLON IF (NPUTE.LT.0.AND.ILS.EQ.0) PRINT 198,K,XLAT,XLON IF (NPUTE.LT.0.AND.ILS.EQ.1) PRINT 199,K,XLAT,XLON 197 FORMAT(1H ,' ==== STATION ',I4,' AT LATLON=',2F8.2, 1 ' DESIRED AS NEAREST POINT') 198 FORMAT(1H ,' ==== STATION ',I4,' AT LATLON=',2F8.2, 1 ' DESIRED AS OCEAN PT') 199 FORMAT(1H ,' ==== STATION ',I4,' AT LATLON=',2F8.2, 1 ' DESIRED AS LAND PT') IF (NPUTE.GT.0.AND.K.GT.1) GO TO 195 ALAT(K) = CON(K+1300) ALON(K) = CON(K+1500) 195 CONTINUE IF (XLON.LT.0) XLON = 360. + CON(K+1500) IF (NPUTE.LT.0) THEN CALL GETIJ (XLAT,XLON,SLIMSK,BLATF,DXF, 1 ILS,ILONF,JLATG,KI,KJ) ILS = -1 CALL GETIJ (XLAT,XLON,SLIMSK,BLATR,DXR, 1 ILS,ILONR,JLATR,KIR,KJR) ELSE ILS = -1 CALL GETIJ (XLAT,XLON,SLIMSK,BLATF,DXF, 1 ILS,ILONF,JLATG,KI,KJ) ILS = -1 CALL GETIJ (XLAT,XLON,SLIMSK,BLATR,DXR, 1 ILS,ILONR,JLATR,KIR,KJR) END IF IGRD(K) = KI JGRD(K) = KJ IGRDR(K) = KIR JGRDR(K) = KJR IF(NPUTE.GT.0) GO TO 5 IF(XLAT.LT.0.) THEN IGRD(K) = KI + ILONF JGRD(K) = JLATG + 1 - KJ IGRDR(K) = KIR + ILONR JGRDR(K) = JLATR + 1 - KJR ENDIF 5 CONTINUE C.... REGIONAL BLOCK , I,J STILL IN SINGLE LATITUDE STRUCTURE.. IF (NPUTE.GT.0) THEN IBACK = IY/2 C.... IF IY = 1 THE ALL WE WANT IS 1 POINT IF (IBACK.LE.0) THEN NPOINT = 1 GO TO 59 END IF ISTARF = IGRD(1) - IBACK*ISKP JSTARF = JGRD(1) - IBACK*ISKP ISTARR = IGRDR(1) - IBACK*ISKP JSTARR = JGRDR(1) - IBACK*ISKP NPOINT = 0 DO 30 KYJ=1,IY DO 30 KXI=1,IY NPOINT = NPOINT + 1 IGRD(NPOINT) = ISTARF + (KXI-1)*ISKP JGRD(NPOINT) = JSTARF + (KYJ-1)*ISKP IGRDR(NPOINT) = ISTARR + (KXI-1)*ISKP JGRDR(NPOINT) = JSTARR + (KYJ-1)*ISKP 30 CONTINUE DO 32 N=1,NPOINT KPOI(N) = 0 IF (JGRD(N).GT.JLATG.OR.JGRD(N).LT.1) GO TO 32 IF (JGRDR(N).GT.JLATR.OR.JGRDR(N).LT.1) GO TO 32 IF (IGRD(N).GT.ILONF) IGRD(N) = IGRD(N) - ILONF IF (IGRD(N).LT.1) IGRD(N) = IGRD(N) + ILONF IF (IGRDR(N).GT.ILONR) IGRDR(N) = IGRDR(N) - ILONR IF (IGRDR(N).LT.1) IGRDR(N) = IGRDR(N) + ILONR KPOI(N) = N 32 CONTINUE C... SQUEEZE OUT THE OUT OF BOUNDS POINTS(KPOI=0) NPP = 0 DO 33 N=1,NPOINT IF (KPOI(N).LE.0) GO TO 33 NPP = NPP + 1 IGRD(NPP) = IGRD(KPOI(N)) IGRDR(NPP) = IGRDR(KPOI(N)) JGRD(NPP) = JGRD(KPOI(N)) JGRDR(NPP) = JGRDR(KPOI(N)) IF (JGRD(NPP).GT.JLATG2) THEN IGRD(NPP) = IGRD(NPP) + ILONF JGRD(NPP) = JLATG+1-JGRD(NPP) END IF IF (JGRDR(NPP).GT.JLATR2) THEN IGRDR(NPP) = IGRDR(NPP) + ILONR JGRDR(NPP) = JLATR+1-JGRDR(NPP) END IF 33 CONTINUE NPOINT = NPP END IF C................... DEBUG PRINT 59 CONTINUE DO 60 K=1,NPOINT IG=IGRD(K) JG=JGRD(K) ICLND=IG JCLND=JG IF(IGRD(K).LE.ILONF) THEN BLAT=90.-COLRAD(JGRD(K))*180./PI BLON=(IGRD(K)-1)*360./ILONF IF(BLON.GT.180.) BLON=BLON-360. ELSE BLAT=COLRAD(JGRD(K))*180./PI-90. BLON=(IGRD(K)-1-ILONF)*360./ILONF IF(BLON.GT.180.) BLON=BLON-360. ICLND=IG-ILONF JCLND=JLATG+1-JG ENDIF WRITE(6,61) K,ALAT(K),ALON(K),BLAT,BLON WRITE(6,62) JGRD(K),IGRD(K),SLIMSK(ICLND,JCLND) WRITE(6,63) JGRDR(K),IGRDR(K) 60 CONTINUE 61 FORMAT(' KENPRE: K,ORIG LAT-LON,COMPT LAT-LON=',I4,4F8.2) 62 FORMAT(' ....JGRD,IGRD,SLMSK=',2I6,F6.1) 63 FORMAT(' ....JGRDR, IGRDR =',2I8) RETURN END SUBROUTINE GETIJ (XLAT,XLON,SLMSK,BLAT,DX, 1 ILS,IDM,JDM,KI,KJ) DIMENSION BLAT(JDM),DIST(4),KENI(4),KENJ(4) DIMENSION IPSORT(4),IPSKP(4) DIMENSION SLMSK( 192 , 94 ) JDM2 = JDM / 2 JDMP1 = JDM2 + 1 IF (ABS(XLAT).GT.BLAT(1)) GO TO 70 C---- GET UPPER LEFT GAUSSIAN POINT (IA,JA) ON GRIDBOX C SURROUNDING THE INPUT LAT/LON POINT........ IA = XLON/DX + 1 IB = IA + 1 IF (IA.GE.IDM) IB = 1 XI = XLON/DX + 1. - IA DO 10 JAK=2,JDMP1 JB = JAK - 1 IF(ABS(XLAT).GT.BLAT(JAK)) GO TO 15 10 CONTINUE 15 CONTINUE JA = JB C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XJ = (BLAT(JA) - ABS(XLAT)) / (BLAT(JA)-BLAT(JA+1)) C XOUT(I,LAT) = (1-XI)* XJ *XIN(IA,JA+1) + CC 1 XI * XJ *XIN(IB,JA+1) + CCC 2 (1-XI)*(1-XJ)*XIN(IA ,JA ) + CCCC 3 XI *(1-XJ)*XIN(IB,JA ) C---- SOUTHERN HEMISPHERE IF (XLAT.LT.0.) THEN JA = JDM - JA XJ = 1. - XJ END IF CCCC XOUT(I,JOUT+1-LAT)=(1-XI)* XJ *XIN(IA,JA+1) + CCC 1 XI * XJ *XIN(IB,JA+1) + CC 2 (1-XI)*(1-XJ)*XIN(IA ,JA ) + C 3 XI *(1-XJ)*XIN(IB,JA ) C... UPPER LEFT POINT DIST(1)= SQRT(XI**2+XJ**2) KENI(1)= IA KENJ(1)= JA C... UPPER RIGHT DIST(2)= SQRT((1-XI)**2+XJ**2) KENI(2)= IB KENJ(2)= JA C... LOWER RIGHT DIST(3)= SQRT((1-XI)**2+(1-XJ)**2) KENI(3)= IB KENJ(3)= JA+1 C... LOWER LEFT DIST(4)= SQRT(XI**2+(1-XJ)**2) KENI(4)= IA KENJ(4)= JA+1 C--- NOW SORT THE DISTANCES (BY INDEX, SHORTEST FIRST) NPT = 4 NPT1 = NPT + 1 DO 20 KD=1,NPT IPSKP(KD) = 0 20 CONTINUE DO 40 KD=1,NPT DD=100. C--- FIND SHORTEST DIST OF THE REMAINING UNSORTED DATA... DO 25 KK=1,NPT IF(IPSKP (KK).GT.0) GO TO 25 IF(DIST(KK).LT.DD) THEN DD = DIST(KK) JX = KK END IF 25 CONTINUE C--- STORE SORTED INDEX IPSORT(KD) = JX IPSKP (JX) = 1 40 CONTINUE PRINT 102,(DIST(KK),KK=1,NPT),(IPSORT(KK),KK=1,NPT) 102 FORMAT(1H ,' DISTANCES=',4F8.4,' SORTED INDICES=',4I4) C--- END OF DISTANCE SORT XILS = ILS IF (ILS.LT.0) THEN KI = KENI(IPSORT(1)) KJ = KENJ(IPSORT(1)) RETURN END IF IF (ILS.EQ.0) THEN C.... FIND NEAREST SEA POINT DO 45 KD=1,NPT II = KENI(IPSORT(KD)) JJ = KENJ(IPSORT(KD)) IF (SLMSK(II,JJ).LE.XILS) GO TO 46 45 CONTINUE C.... NO SEA POINTS SO DEFAULT TO NEAREST POINT PRINT 49,XLAT,XLON 49 FORMAT(1H ,' ASKED FOR SEA POINT BUT CAN T FIND ONE FOR', 1 ' LAT LON=',2F9.2,'..SO DEFAULT TO NEAREST') KI = KENI(IPSORT(1)) KJ = KENJ(IPSORT(1)) RETURN 46 CONTINUE KI = II KJ = JJ RETURN END IF IF (ILS.EQ.1) THEN C.... FIND NEAREST LAND/ICE POINT DO 55 KD=1,NPT II = KENI(IPSORT(KD)) JJ = KENJ(IPSORT(KD)) IF (SLMSK(II,JJ).GE.XILS) GO TO 56 55 CONTINUE C.... NO LAND POINTS SO DEFAULT TO NEAREST POINT PRINT 59,XLAT,XLON 59 FORMAT(1H ,' ASKED FOR LAND SEA POINT BUT CAN T FIND ONE FOR', 1 ' LAT LON=',2F9.2,'..SO DEFAULT TO NEAREST') KI = KENI(IPSORT(1)) KJ = KENJ(IPSORT(1)) RETURN 56 CONTINUE KI = II KJ = JJ RETURN END IF C... OUTSIDE LIMIT OF GAUSSIAN POLAR ROWS SO JUST TAKE NEAREST C POINT WITHOUT REGARD TO LAND AND SEA 70 CONTINUE IA = XLON/DX + 1 IB = IA + 1 IF (IA.GE.IDM) IB = 1 XI = XLON/DX + 1. - IA JA = 1 IF (XLAT.LT.0.) JA = JDM IF (XI.GT.0.5) THEN KI = IB KJ = JA ELSE KI = IA KJ = JA END IF RETURN END SUBROUTINE DFINI(ICALL,HRINI,CHOUR,SOLSEC) C................................................................. C..... C C................................................................. C................BEGIN TWOLOOP(COMFIBM)........................ C.... C VERSION WITH STACKED TRANSFORMS C.... C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfgrid................................... C.... COMMON /comfgrid/ * COLRAD( 47 ),WGT( 47 ),WGTCS( 47 ),RCS2( 47 ), * COLRAB( 47 ),WGB( 47 ),WGBCS( 47 ),RBS2( 47 ), * SINLAT( 47 ), * SINLAB( 384 , 47 ),COSLAB( 384 , 47 ) C................................................................. C................sof comfgrid................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C.... C.... C.....BEGIN comfver............................................... COMMON/comfver/AM( 28 , 28 ),HM( 28 , 28 ),TM( 28 , 28 ), O BM( 28 , 28 ),CM( 28 , 28 ),SPDMAX( 28 ), 1 SI( 29 ),SL( 28 ),DEL( 28 ),RDEL2( 28 ),RMSDOT( 27 ), 2 CI( 29 ),CL( 28 ),TOV( 28 ),GV( 28 ),SV( 28 ),RPI( 27 ), 3 P1( 28 ),P2( 28 ), H1( 28 ), H2( 28 ),RPIREC( 27 ), 8 THOUR,DELTIM,KDT,INISTP,SL1,Z00,FHOUR,SHOUR,DTCVAV, 9 LIMLOW,NFLIP,NFLOP,NR2DDA,FILTA,FILTB,DK,TK,PERCUT,DTSWAV, X DTLWAV,COWAVE,DTWAVE,N50UFL,NUMSUM,NUMMAX,NDUMY0 C-CRA& ,NCLDB1,NCPUS,NCPUS1 C.....sof comfver............................................... C.... C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C.... C.... COMMON /RADIAG/ FLUXR( 384 , 47 ,26) C EQUIVALENCE (FFLWUP(1,1),FLUXR(1,1,1)),(FFSWUP(1,1),FLUXR(1,1,2)), C 1 (FSSWUP(1,1),FLUXR(1,1,3)),(FSSWDN(1,1),FLUXR(1,1,4)), C 2 (CCHI (1,1),FLUXR(1,1,5)),(CCMID (1,1),FLUXR(1,1,6)), C 3 (CCLO (1,1),FLUXR(1,1,7)),(CTPH (1,1),FLUXR(1,1,8)), C 4 (CTPM (1,1),FLUXR(1,1,9)), (CTPL (1,1),FLUXR(1,1,10)), C 5 (CBTH (1,1),FLUXR(1,1,11)),(CBTM (1,1),FLUXR(1,1,12)), C 6 (CBTL (1,1),FLUXR(1,1,13)),(CTHTMP(1,1),FLUXR(1,1,14)), C 7 (CTMTMP(1,1),FLUXR(1,1,15)),(CTLTMP(1,1),FLUXR(1,1,16)), C 8 (ALBDO (1,1),FLUXR(1,1,17)),(FFSWDN(1,1),FLUXR(1,1,18)), C 9 (SLWDN (1,1),FLUXR(1,1,19)),(SLWUP (1,1),FLUXR(1,1,20)), C 1 (FLWUPC(1,1),FLUXR(1,1,21)),(FSWUPC(1,1),FLUXR(1,1,22)), C 2 (SSWDNC(1,1),FLUXR(1,1,23)),(SSWUPC(1,1),FLUXR(1,1,24)), C 3 (SLWDNC(1,1),FLUXR(1,1,25)),(TOTALC(1,1),FLUXR(1,1,26)) COMMON /RADIAG/ CVAVG( 384 , 47 ) COMMON /RADIAG/ ILEFT( 384 ),IRGHT( 384 ),WGTLON( 384 ) COMMON /RADIAG/ INSLAT( 47 ),IDUMMY( 47 ),WGTLAT( 47 ) C............................................................. C.................SOF TWOLOOP(COMFIBM)........................ C................................................................ C..... COMMON/INIGSM/ DTHOUR , DSHOUR, DCHOUR, DSOLSEC, TOTSUM 2 ,QS( 4032 ) 2 ,TES( 4032 , 28 ),RQS( 4032 , 28 ) 2 ,DIS( 4032 , 28 ),ZES( 4032 , 28 ) C IF(NUMSUM.GE.NUMMAX) RETURN C IF( ICALL.EQ.0 ) THEN PRINT *,' INITIAL DFINI ' PRINT *,' INI TIME IS ',HRINI,' HOUR.' DO 10 K=1, 28 DO 10 I=1, 4032 DIS(I,K) = 0.0 ZES(I,K) = 0.0 TES(I,K) = 0.0 10 CONTINUE DO 11 K=1, 28 DO 11 I=1, 4032 RQS(I,K) = 0.0 11 CONTINUE DO 12 I=1, 4032 QS(I) = 0.0 12 CONTINUE TOTSUM=0.0 ENDIF C NUMSUM=NUMSUM+1 PRINT *,' ---- IN DFINI ---- NUMSUM NUMMAX ',NUMSUM,NUMMAX IF( NUMSUM.NE.0 ) THEN SC = 3.141593E+0 / NUMMAX SX= NUMSUM*SC TX= NUMSUM* 3.141593E+0 WX= TX/ ( NUMMAX+1 ) DIGFIL= SIN(WX)/WX * SIN(SX)/TX ELSE DIGFIL = 1.0/NUMMAX ENDIF TOTSUM = TOTSUM + DIGFIL C C C------------------------DO SUMMATION WITH WINDOW--- C C FIRST LAT LOOP C$DOACROSS SHARE(DI ,ZE ,TE ,RQ , Q, C$& DIS,ZES,TES,RQS, QS, C$& DIGFIL), C$& LOCAL(J,K) CMIC$ DO ALL CMIC$1 SHARED(DI ,ZE ,TE ,RQ , Q ) CMIC$1 SHARED(DIS,ZES,TES,RQS, QS) CMIC$1 SHARED(DIGFIL) CMIC$1 PRIVATE(J,K) C AUTOSCOPE C C .......OBTAIN FULL FIELD VALUES DO 110 K=1, 28 DO 110 J=1, 4032 DIS(J,K) = DIS(J,K) + DIGFIL*DI(J,K) ZES(J,K) = ZES(J,K) + DIGFIL*ZE(J,K) TES(J,K) = TES(J,K) + DIGFIL*TE(J,K) 110 CONTINUE DO 111 K=1, 28 DO 111 J=1, 4032 RQS(J,K) = RQS(J,K) + DIGFIL*RQ(J,K) 111 CONTINUE DO 120 J=1, 4032 QS(J) = QS(J) + DIGFIL*Q(J) 120 CONTINUE C................................................ C SAVE IF( NUMSUM.EQ.0 ) THEN DTHOUR=THOUR DSHOUR=SHOUR DCHOUR=CHOUR DSOLSEC=SOLSEC PRINT *,' NUMSUM=0, SAVE THOUR= ',DTHOUR CALL FIXIO(THOUR,TSEA,SMC,SHELEG,STC,TG3,ZORL,PLANTR, 1 CV,CVB,CVT,ALBEDO,SLMSK,F10M,CANOPY,1,NFLIP,NFLOP) ENDIF C................................................ C RESTORE IF( NUMSUM.EQ.NUMMAX ) THEN PRINT *,' NUMSUM=NUMMAX REASSIGN PERTURBATION ' PRINT *,' WITH NORMALIZED FACTOR=',TOTSUM,' AT HOUR=',DTHOUR HRINI=0 THOUR=DTHOUR SHOUR=DSHOUR CHOUR=DCHOUR SOLSEC=DSOLSEC CALL FIXIO(THOUR,TSEA,SMC,SHELEG,STC,TG3,ZORL,PLANTR, 1 CV,CVB,CVT,ALBEDO,SLMSK,F10M,CANOPY,0,NFLOP,0) C$DOACROSS SHARE(DI ,ZE ,TE ,RQ , Q, C$& DIS,ZES,TES,RQS, QS, C$& DIM,ZEM,TEM, RM, QM, C$& TOTSUM), C$& LOCAL(J,K) CMIC$ DO ALL CMIC$1 SHARED(DI ,ZE ,TE ,RQ , Q ) CMIC$1 SHARED(DIS,ZES,TES,RQS, QS) CMIC$1 SHARED(DIM,ZEM,TEM, RM, QM) CMIC$1 SHARED(TOTSUM) CMIC$1 PRIVATE(J,K) C AUTOSCOPE DO 210 K=1, 28 DO 210 J=1, 4032 DI (J,K) = DIS(J,K) / TOTSUM ZE (J,K) = ZES(J,K) / TOTSUM TE (J,K) = TES(J,K) / TOTSUM DIM(J,K) = DIS(J,K) / TOTSUM ZEM(J,K) = ZES(J,K) / TOTSUM TEM(J,K) = TES(J,K) / TOTSUM 210 CONTINUE DO 211 K=1, 28 DO 211 J=1, 4032 RQ (J,K) = RQS(J,K) / TOTSUM RM (J,K) = RQS(J,K) / TOTSUM 211 CONTINUE DO 220 J=1, 4032 QM(J) = QS(J) / TOTSUM Q (J) = QS(J) / TOTSUM 220 CONTINUE DO 230 L=1, 47 DO 230 J=1, 384 GESHEM(J,L)=0.5*GESHEM(J,L) 230 CONTINUE CALL MLTFLX(0.5,DUSFC,DVSFC,DTSFC,DQSFC,DLWSFC,ULWSFC, 1 BENGSH,GFLUX, 2 DUGWD,DVGWD,PSMEAN) CALL MLTDIA(0.5) CALL ZNLMLT(0.5) C-CRA FLUXR=0.5*FLUXR C-CRA CVAVG=0.5*CVAVG DO I=1, 384 DO J=1, 47 DO K=1,25 FLUXR(I,J,K)=0.5*FLUXR(I,J,K) ENDDO ENDDO ENDDO DO I=1, 384 DO J=1, 47 CVAVG(I,J)=0.5*CVAVG(I,J) ENDDO ENDDO ENDIF C................................................ C RETURN END SUBROUTINE MAXMIN(F,IDIM,JDIM,IMAX,JMAX,KMAX) C DIMENSION F(IDIM,JDIM,KMAX) C DO 10 K=1,KMAX C FMAX=F(1,1,K) FMIN=F(1,1,K) C DO 20 J=1,JMAX DO 20 I=1,IMAX IF(FMAX.LE.F(I,J,K)) THEN FMAX=F(I,J,K) IIMAX=I JJMAX=J ENDIF IF(FMIN.GE.F(I,J,K)) THEN FMIN=F(I,J,K) IIMIN=I JJMIN=J ENDIF 20 CONTINUE C print *,'LEV=',K,' MAX=',FMAX,' AT I=',IIMAX,' J=',JJMAX, 1 ' MIN=',FMIN,' AT I=',IIMIN,' J=',JJMIN c c WRITE(6,100) K,FMAX,IIMAX,JJMAX,FMIN,IIMIN,JJMIN c 100 FORMAT(2X,'LEVEL=',I2,' MAX=',E10.4,' AT I=',I5,' J=',I5, c 1 ' MIN=',E10.4,' AT I=',I5,' J=',I5) C 10 CONTINUE C RETURN END SUBROUTINE LFMFINI(IPSTEP,FHOUR) C C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C COMMON/COMLFM/ WEIGHT(1000) COMMON/COMLFM/ FQ( 4033 ) COMMON/COMLFM/ FTE( 4033 , 28 ) COMMON/COMLFM/ FDI( 4033 , 28 ) COMMON/COMLFM/ FZE( 4033 , 28 ) COMMON/COMLFM/ FRQ( 4033 , 28 ) COMMON/COMLFM/ FTSEA( 384 , 47 ),FSMC( 384 , 47 , 2 ), 1 FSHELEG( 384 , 47 ),FSTC( 384 , 47 , 2 ), 2 FTG3( 384 , 47 ),FZORL( 384 , 47 ), 3 FPLANTR( 384 , 47 ), 4 FCV( 384 , 47 ),FCVB( 384 , 47 ),FCVT( 384 , 47 ), 5 FALBEDO( 384 , 47 ),FSLMSK( 384 , 47 ), 6 FF10M( 384 , 47 ),FCANOPY( 384 , 47 ) COMMON/COMLFM/ ISLMSK( 384 , 47 ,3), 1 WCVB( 384 , 47 ),WCVT( 384 , 47 ) COMMON/COMLFM/ FILTWIN,KLENP,NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO C PARAMETER(CVB0=100.,CVT0=0.) C C DIMENSION IDATE(4) C WRITE(6,*) 'LFMFINI CALLED. FHOUR=',FHOUR C C NON-EXISTENT NLFMSGI IS USED FOR START OF FILTERING INTEGRATION C READ(NLFMSGI,END=999,ERR=999) LAB GO TO 888 C C START OF NEW FILTERING INTEGRATION C 999 CONTINUE IPSTEP=1 C C ZERO OUT OUTPUT SURFACE ARRAY C DO J=1, 47 DO I=1, 384 ISLMSK(I,J,1)=0 ISLMSK(I,J,2)=0 ISLMSK(I,J,3)=0 ENDDO ENDDO DO L=1, 4032 FQ(L)=FQ(L)+QM(L)*WEIGHT(1) ENDDO DO K=1, 28 DO L=1, 4032 FTE(L,K)=TEM(L,K)*WEIGHT(1) FDI(L,K)=DIM(L,K)*WEIGHT(1) FZE(L,K)=ZEM(L,K)*WEIGHT(1) FRQ(L,K)=RM(L,K)*WEIGHT(1) ENDDO ENDDO C DO J=1, 47 DO I=1, 384 FTSEA(I,J)=TSEA(I,J)*WEIGHT(1) FSHELEG(I,J)=SHELEG(I,J)*WEIGHT(1) FTG3(I,J)=TG3(I,J)*WEIGHT(1) FZORL(I,J)=ZORL(I,J)*WEIGHT(1) FPLANTR(I,J)=PLANTR(I,J)*WEIGHT(1) FCV(I,J)=CV(I,J)*WEIGHT(1) FALBEDO(I,J)=ALBEDO(I,J)*WEIGHT(1) FF10M(I,J)=F10M(I,J)*WEIGHT(1) FCANOPY(I,J)=FCANOPY(I,J)*WEIGHT(1) ISL=NINT(SLMSK(I,J))+1 ISLMSK(I,J,ISL)=ISLMSK(I,J,ISL)+1 IF(CVB(I,J).NE.CVB0) THEN FCVB(I,J)=CVB(I,J)*WEIGHT(1) WCVB(I,J)=WEIGHT(1) ELSE FCVB(I,J)=0. WCVB(I,J)=0. ENDIF IF(CVT(I,J).NE.CVT0) THEN FCVT(I,J)=CVT(I,J)*WEIGHT(1) WCVT(I,J)=WEIGHT(1) ELSE FCVT(I,J)=0. WCVT(I,J)=0. ENDIF ENDDO ENDDO DO K=1, 2 DO J=1, 47 DO I=1, 384 FSMC(I,J,K)=SMC(I,J,K)*WEIGHT(1) FSTC(I,J,K)=STC(I,J,K)*WEIGHT(1) ENDDO ENDDO ENDDO RETURN C C CONTINUATION OF FILTERING INTEGRATION C 888 CONTINUE READ(NLFMSGI) IPSTEP,IDATE WRITE(6,*) 'IPSTEP,IDATE of filtered SIG=',IPSTEP,IDATE READ(NLFMSGI) READ(NLFMSGI)(FQ(I),I=1, 4032 ) DO K=1, 28 READ(NLFMSGI) (FTE(I,K),I=1, 4032 ) ENDDO DO K=1, 28 READ(NLFMSGI) (FDI(I,K),I=1, 4032 ) READ(NLFMSGI) (FZE(I,K),I=1, 4032 ) ENDDO DO K=1, 28 READ(NLFMSGI) (FRQ(I,K),I=1, 4032 ) ENDDO C READ(NLFMSFI) LAB READ(NLFMSFI) IGSTEP,IDATE WRITE(6,*) 'IGSTEP,IDATE of filtered SFC=',IGSTEP,IDATE IF(IGSTEP.NE.IPSTEP) THEN WRITE(6,*) 'NO. OF STEPS ON SIG AND SFC DOES NOT MATCH' CALL ABORT ENDIF READ(NLFMSFI) FTSEA READ(NLFMSFI) FSMC READ(NLFMSFI) FSHELEG READ(NLFMSFI) FSTC READ(NLFMSFI) FTG3 READ(NLFMSFI) FZORL READ(NLFMSFI) FCV READ(NLFMSFI) FCVB,WCVB READ(NLFMSFI) FCVT,WCVT READ(NLFMSFI) FALBEDO READ(NLFMSFI) ISLMSK READ(NLFMSFI) FPLANTR READ(NLFMSFI) FCANOPY READ(NLFMSFI) FF10M C RETURN END SUBROUTINE LFMFILT(IFSTEP,THOUR) C C................................................................. C................BEGIN comfspec................................... C.... COMMON /comfspec/ IDATE(4),RELVOR( 28 ),ABSVOR( 28 ), 1 EPS( 4032 ),EPSI( 4032 ),GZ( 4033 ) COMMON /comfspec/ * ZEM ( 4033 , 28 ), * DIM ( 4033 , 28 ), * TEM ( 4033 , 28 ), * RM ( 4033 , 28 ), * QM ( 4033 ) COMMON /comfspec/ * ZE ( 4033 , 28 ), * DI ( 4033 , 28 ), * TE ( 4033 , 28 ), * RQ ( 4033 , 28 ), * DPDLAM ( 4033 ), * DPDPHI ( 4033 ), * ULN ( 4033 , 28 ), * VLN ( 4033 , 28 ), * Q ( 4033 ) COMMON /comfspec/ * X ( 4033 , 28 ), * Y ( 4033 , 28 ), * RT ( 4033 , 28 ), * Z ( 4033 ), * W ( 4033 , 28 ) C................................................................. C................sof comfspec................................... C.... C................................................................. C................BEGIN comfphys .................................. C.... COMMON /comfphys/SLMSK( 384 , 47 ),HPRIME( 384 , 47 ), * SWH( 384 , 28 , 47 ),HLW( 384 , 28 , 47 ), * SFCNSW( 384 , 47 ),SFCDLW( 384 , 47 ), * COSZEN( 384 , 47 ),XLON( 384 , 47 ), * SDEC,CDEC,SLAG,SOLHR,CLSTP,LASTEP,LDUM0, * CV( 384 , 47 ),CVT( 384 , 47 ),CVB( 384 , 47 ), * ALBEDO( 384 , 47 ),TSFLW( 384 , 47 ), * DUSFC( 384 , 47 ), DVSFC( 384 , 47 ), * DTSFC( 384 , 47 ), DQSFC( 384 , 47 ), * DLWSFC( 384 , 47 ),ULWSFC( 384 , 47 ), *GESHEM( 384 , 47 ),TSEA( 384 , 47 ),F10M( 384 , 47 ), * DUGWD( 384 , 47 ),DVGWD( 384 , 47 ), * U10M( 384 , 47 ),V10M( 384 , 47 ), * T2M( 384 , 47 ),Q2M( 384 , 47 ), * PSURF( 384 , 47 ),PSMEAN( 384 , 47 ), *TG3( 384 , 47 ),ZORL( 384 , 47 ),PLANTR( 384 , 47 ), * SHELEG( 384 , 47 ),BENGSH( 384 , 47 ), * GFLUX( 384 , 47 ),SLRAD( 384 ), * SMC( 384 , 47 , 2 ),STC( 384 , 47 , 2 ), * CANOPY( 384 , 47 ),RUNOFF( 384 , 47 ), * TMPMAX( 384 , 47 ),TMPMIN( 384 , 47 ), * EP( 384 , 47 ),CLDWRK( 384 , 47 ), * HPBL( 384 , 47 ),PWAT( 384 , 47 ), * SNOWMELT( 384 , 47 ),SNOWFALL( 384 , 47 ), * SNOWEVAP( 384 , 47 ) LOGICAL LASTEP C................................................................. C................sof comfphys .................................. C.... C COMMON/COMLFM/ WEIGHT(1000) COMMON/COMLFM/ FQ( 4033 ) COMMON/COMLFM/ FTE( 4033 , 28 ) COMMON/COMLFM/ FDI( 4033 , 28 ) COMMON/COMLFM/ FZE( 4033 , 28 ) COMMON/COMLFM/ FRQ( 4033 , 28 ) COMMON/COMLFM/ FTSEA( 384 , 47 ),FSMC( 384 , 47 , 2 ), 1 FSHELEG( 384 , 47 ),FSTC( 384 , 47 , 2 ), 2 FTG3( 384 , 47 ),FZORL( 384 , 47 ), 3 FPLANTR( 384 , 47 ), 4 FCV( 384 , 47 ),FCVB( 384 , 47 ),FCVT( 384 , 47 ), 5 FALBEDO( 384 , 47 ),FSLMSK( 384 , 47 ), 6 FF10M( 384 , 47 ),FCANOPY( 384 , 47 ) COMMON/COMLFM/ ISLMSK( 384 , 47 ,3), 1 WCVB( 384 , 47 ),WCVT( 384 , 47 ) COMMON/COMLFM/ FILTWIN,KLENP,NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO C WRITE(6,*) 'DOING LFMFILT FOR IFSTEP=',IFSTEP DO L=1, 4032 FQ(L)=FQ(L)+Q(L)*WEIGHT(IFSTEP) ENDDO DO K=1, 28 DO L=1, 4032 FTE(L,K)=FTE(L,K)+TE(L,K)*WEIGHT(IFSTEP) FDI(L,K)=FDI(L,K)+DI(L,K)*WEIGHT(IFSTEP) FZE(L,K)=FZE(L,K)+ZE(L,K)*WEIGHT(IFSTEP) FRQ(L,K)=FRQ(L,K)+RQ(L,K)*WEIGHT(IFSTEP) ENDDO ENDDO C DO J=1, 47 DO I=1, 384 FTSEA(I,J)=FTSEA(I,J)+TSEA(I,J)*WEIGHT(IFSTEP) FSHELEG(I,J)=FSHELEG(I,J)+SHELEG(I,J)*WEIGHT(IFSTEP) FTG3(I,J)=FTG3(I,J)+TG3(I,J)*WEIGHT(IFSTEP) FZORL(I,J)=FZORL(I,J)+ZORL(I,J)*WEIGHT(IFSTEP) FPLANTR(I,J)=FPLANTR(I,J)+PLANTR(I,J)*WEIGHT(IFSTEP) FCV(I,J)=FCV(I,J)+CV(I,J)*WEIGHT(IFSTEP) FALBEDO(I,J)=FALBEDO(I,J)+ALBEDO(I,J)*WEIGHT(IFSTEP) FF10M(I,J)=FF10M(I,J)+F10M(I,J)*WEIGHT(IFSTEP) FCANOPY(I,J)=FCANOPY(I,J)+CANOPY(I,J)*WEIGHT(IFSTEP) ISL=NINT(SLMSK(I,J))+1 ISLMSK(I,J,ISL)=ISLMSK(I,J,ISL)+1 IF(CVB(I,J).NE.CVB0) THEN FCVB(I,J)=FCVB(I,J)+CVB(I,J)*WEIGHT(IFSTEP) WCVB(I,J)=WCVB(I,J)+WEIGHT(IFSTEP) ENDIF IF(CVT(I,J).NE.CVT0) THEN FCVT(I,J)=FCVT(I,J)+CVT(I,J)*WEIGHT(IFSTEP) WCVT(I,J)=WCVT(I,J)+WEIGHT(IFSTEP) ENDIF ENDDO ENDDO DO K=1, 2 DO J=1, 47 DO I=1, 384 FSMC(I,J,K)=FSMC(I,J,K)+SMC(I,J,K)*WEIGHT(IFSTEP) FSTC(I,J,K)=FSTC(I,J,K)+STC(I,J,K)*WEIGHT(IFSTEP) ENDDO ENDDO ENDDO RETURN END SUBROUTINE LFMFOUT(IFSTEP,THOUR,NZ) C COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB C COMMON/COMLFM/ WEIGHT(1000) COMMON/COMLFM/ FQ( 4033 ) COMMON/COMLFM/ FTE( 4033 , 28 ) COMMON/COMLFM/ FDI( 4033 , 28 ) COMMON/COMLFM/ FZE( 4033 , 28 ) COMMON/COMLFM/ FRQ( 4033 , 28 ) COMMON/COMLFM/ FTSEA( 384 , 47 ),FSMC( 384 , 47 , 2 ), 1 FSHELEG( 384 , 47 ),FSTC( 384 , 47 , 2 ), 2 FTG3( 384 , 47 ),FZORL( 384 , 47 ), 3 FPLANTR( 384 , 47 ), 4 FCV( 384 , 47 ),FCVB( 384 , 47 ),FCVT( 384 , 47 ), 5 FALBEDO( 384 , 47 ),FSLMSK( 384 , 47 ), 6 FF10M( 384 , 47 ),FCANOPY( 384 , 47 ) COMMON/COMLFM/ ISLMSK( 384 , 47 ,3), 1 WCVB( 384 , 47 ),WCVT( 384 , 47 ) COMMON/COMLFM/ FILTWIN,KLENP,NLFMSGI,NLFMSFI,NLFMSGO,NLFMSFO C DIMENSION SI( 29 ),SL( 28 ),IDATE(4) C DIMENSION GZ( 4032 ) C DIMENSION FSLMSK( 384 , 47 ) C DIMENSION FCVB( 384 , 47 ),FCVT( 384 , 47 ) DIMENSION WORK( 384 * 47 ) C REWIND NZ READ(NZ) READ(NZ) DUMMY,IDATE,(SI(K),K=1, 29 ),(SL(K),K=1, 28 ) C WRITE(6,*) 'LFMFOUT IFSTEP=',IFSTEP,' KLENP=',KLENP IF(IFSTEP.EQ.KLENP) THEN VHOUR=NINT(THOUR-FILTWIN*0.5) WRITE(6,*) 'VHOUR,IDATE of filtered output SIG=',VHOUR,IDATE WRITE(NLFMSGO) LAB WRITE(NLFMSGO) VHOUR,IDATE,(SI(K),K=1, 29 ),(SL(K),K=1, 28 ) READ(NZ)(GZ(I),I=1, 4032 ) WRITE(NLFMSGO)(GZ(I),I=1, 4032 ) WRITE(NLFMSGO)(FQ(I),I=1, 4032 ) DO K=1, 28 WRITE(NLFMSGO) (FTE(I,K),I=1, 4032 ) ENDDO DO K=1, 28 WRITE(NLFMSGO) (FDI(I,K),I=1, 4032 ) WRITE(NLFMSGO) (FZE(I,K),I=1, 4032 ) ENDDO DO K=1, 28 WRITE(NLFMSGO) (FRQ(I,K),I=1, 4032 ) ENDDO C WRITE(NLFMSFO) LAB WRITE(NLFMSFO) VHOUR,IDATE CALL ROWSEP(FTSEA) WRITE(NLFMSFO) FTSEA DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = FSMC(I,J,K) ENDDO ENDDO CALL ROWSEP(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I FSMC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO WRITE(NLFMSFO) FSMC CALL ROWSEP(FSHELEG) WRITE(NLFMSFO) FSHELEG DO K = 1, 2 DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I WORK(IJ) = FSTC(I,J,K) ENDDO ENDDO CALL ROWSEP(WORK) DO J = 1, 47 DO I = 1, 384 IJ = (J-1) * 384 + I FSTC(I,J,K) = WORK(IJ) ENDDO ENDDO ENDDO WRITE(NLFMSFO) FSTC CALL ROWSEP(FTG3) WRITE(NLFMSFO) FTG3 CALL ROWSEP(FZORL) WRITE(NLFMSFO) FZORL CALL ROWSEP(FCV) WRITE(NLFMSFO) FCV DO J=1, 47 DO I=1, 384 IF(WCVB(I,J).GE.0.5) THEN FCVB(I,J)=FCVB(I,J)/WCVB(I,J) ENDIF ENDDO ENDDO CALL ROWSEP(FCVB) WRITE(NLFMSFO) FCVB DO J=1, 47 DO I=1, 384 IF(WCVT(I,J).GE.0.5) THEN FCVT(I,J)=FCVT(I,J)/WCVT(I,J) ENDIF ENDDO ENDDO CALL ROWSEP(FCVT) WRITE(NLFMSFO) FCVT CALL ROWSEP(FALBEDO) WRITE(NLFMSFO) FALBEDO DO J=1, 47 DO I=1, 384 IF(ISLMSK(I,J,3).GE.KLENP/2) THEN FSLMSK(I,J)=2. ELSEIF(ISLMSK(I,J,1).GT.ISLMSK(I,J,2)) THEN FSLMSK(I,J)=0. ELSE FSLMSK(I,J)=1. ENDIF ENDDO ENDDO CALL ROWSEP(FSLMSK) WRITE(NLFMSFO) FSLMSK CALL ROWSEP(FPLANTR) WRITE(NLFMSFO) FPLANTR CALL ROWSEP(FCANOPY) WRITE(NLFMSFO) FCANOPY CALL ROWSEP(FF10M) WRITE(NLFMSFO) FF10M ELSE WRITE(NLFMSGO) LAB WRITE(NLFMSGO) IFSTEP,IDATE,(SI(K),K=1, 29 ),(SL(K),K=1, 28 ) WRITE(6,*) 'IFSTEP,IDATE of filtered SIG=',IFSTEP,IDATE WRITE(NLFMSGO)(GZ(I),I=1, 4032 ) WRITE(NLFMSGO)(FQ(I),I=1, 4032 ) DO K=1, 28 WRITE(NLFMSGO) (FTE(I,K),I=1, 4032 ) ENDDO DO K=1, 28 WRITE(NLFMSGO) (FDI(I,K),I=1, 4032 ) WRITE(NLFMSGO) (FZE(I,K),I=1, 4032 ) ENDDO DO K=1, 28 WRITE(NLFMSGO) (FRQ(I,K),I=1, 4032 ) ENDDO C C SURFACE FILE C WRITE(NLFMSFO) LAB WRITE(NLFMSFO) IFSTEP,IDATE WRITE(6,*) 'IFSTEP,IDATE of filtered SFC=',IFSTEP,IDATE WRITE(NLFMSFO) FTSEA WRITE(NLFMSFO) FSMC WRITE(NLFMSFO) FSHELEG WRITE(NLFMSFO) FSTC WRITE(NLFMSFO) FTG3 WRITE(NLFMSFO) FZORL WRITE(NLFMSFO) FCV WRITE(NLFMSFO) FCVB,WCVB WRITE(NLFMSFO) FCVT,WCVT WRITE(NLFMSFO) FALBEDO WRITE(NLFMSFO) ISLMSK WRITE(NLFMSFO) FPLANTR WRITE(NLFMSFO) FCANOPY WRITE(NLFMSFO) FF10M ENDIF RETURN END CFPP$ NOCONCUR R SUBROUTINE MONINP(IM,IM2,KM,A,B,TAU,RTG, 1 U1,V1,T1,Q1, 2 PSTAR,RBSOIL,CD,CH,FM,FH,TSEA,QSS,DPHI,SPD1, 3 SI,DEL,SL,SLK,RCL,DELTIM,LAT,KDT,THOUR, 4 DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ,slmask) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MONINp COMPUTES VERTICAL DIFFUSION TERMS. C PRGMMRS: MRB PERSONNEL ORG: W/NMC23 DATE: 88-04-29 C C ABSTRACT: SR MONINp COMPUTES THE PARAMETERIZED EFFECTS C OF VERTICAL TURBULENT EDDY DIFFUSION OF MOMENTUM C WATER VAPOR AND SENSIBLE HEAT IN THE MRF MODEL. C USES STABILITY DEPENDENT MIXING COEFFICIENTS C SUGGESTED BY P. LONG AFTER ECMWF METHODS. C INCORPORATES LOWER BOUNDARY FLUXES USING DRAG C COEFFICIENTS BASED ON MONIN OBUKHOV FORMULAE WHICH C ARE CALCULATED IN SR PROGTN. SPLIT IMPLICIT C INTEGRATION APPROXIMATIONS ARE USED FOLLOWING THE C GFDL TECHNIQUE. THE SOLUTIONS OBTAINED ARE FOR THE C TIME TENDENCIES OF U V T AND Q, AND (BEFORE RETURN) C THESE ARE ADDED TO THE TENDENCIES PASSED. C ALSO RETURNED IS A QUANTITY C DLAM REQUIRED FOR SURFACE HYDROLOGY COMPUTATIONS. C C PROGRAM HISTORY LOG: C 88-04-29 HUA-LU PAN C 88-10-28 SELA C 92-09-01 IREDELL C C USAGE: CALL MONINP(IDIMT,IDIMT2,KDIM,A,B,TAU,RTG, C 1 U1,V1,T1,Q1,TOV, C 2 CD,PSTAR,CDQ,QSS,DPHI,DLAM, C 3 SI,DEL,CL,SL,RCL,DELTIM,TSEA,LAT,KDT,THOUR, C 4 DUSFC,DVSFC,DTSFC,DQSFC) C INPUT ARGUMENT LIST: C IDIMT - NUMBER OF PROFILES TO COMPUTE C IDIMT2 - FIRST DIMENSION OF FIELD SLICES C KDIM - NUMBER OF VERTICAL LEVELS C A - (IDIMT,KDIM) NEGATIVE TENDENCY FOR V WIND IN M/S/S C B - (IDIMT,KDIM) TENDENCY FOR U WIND IN M/S/S C TAU - (IDIMT,KDIM) TENDENCY FOR TEMPERATURE IN K/S C RTG - (IDIMT,KDIM) TENDENCY FOR SPECIFIC HUMIDITY IN KG/KG/S C U1 - (IDIMT2,KDIM) ZONAL WIND * COS(LAT) IN M/S C V1 - (IDIMT2,KDIM) MERID WIND * COS(LAT) IN M/S C T1 - (IDIMT2,KDIM) TEMPERATURE IN K C Q1 - (IDIMT2,KDIM) SPECIFIC HUMIDITY IN KG/KG C TOV - (KDIM) BASE TEMPERATURE IN K C CD - (IDIMT) 1/(FM*FM) MOMENTUM EXCHANGE COEFFICIENT C PSTAR - (IDIMT) SURFACE PRESSURE IN KPA C CD - (IDIMT) 1/(FM*FM) HEAT & MOISTURE EXCHANGE COEFFICIENT C QSS - (IDIMT) SPECIFIC HUMIDITY AT SURFACE IN KG/KG C DPHI - (IDIMT) COEFFICIENT MODULATING SFC EVAPORATION C SI - (KDIM+1) P/PSFC AT BASE OF LAYER C DEL - (KDIM) POSITIVE INCREMENT OF P/PSFC ACROSS LAYER C CL - (KDIM) =1-SL C SL - (KDIM) P/PSFC AT MIDDLE OF LAYER C RCL - RECIPROCAL OF SQUARE OF COS(LAT) C DELTIM - TIME STEP IN SECS C TSEA - (IDIMT) SURFACE TEMPERATURE IN K C LAT - LATITUDE NUMBER C KDT - TIMESTEP NUMBER C THOUR - FORECAST HOUR C OUTPUT ARGUMENT LIST: C A - (IDIMT,KDIM) NEGATIVE TENDENCY FOR V WIND IN M/S/S C B - (IDIMT,KDIM) TENDENCY FOR U WIND IN M/S/S C TAU - (IDIMT,KDIM) TENDENCY FOR TEMPERATURE IN K/S C RTG - (IDIMT,KDIM) TENDENCY FOR SPECIFIC HUMIDITY IN KG/KG/S C DUSFC - (IDIMT) ZONAL STRESS ON SURFACE IN N/M**2 C DVSFC - (IDIMT) MERID STRESS ON SURFACE IN N/M**2 C DTSFC - (IDIMT) SENSIBLE HEAT FLUX ON SURFACE IN W/M**2 C DQSFC - (IDIMT) LATENT HEAT FLUX ON SURFACE IN W/M**2 C C SUBPROGRAMS CALLED: C TRIDI2 - SOLVE TRIDIAGONAL MATRIX EQUATION C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C C$$$ PARAMETER(CP= 1.0046E+3 ,G= 9.8000E+0 ,RD= 2.8705E+2 ,RV= 4.6150E+ 12 ,HVAP= 2.5000E+6 ) PARAMETER(GOR=G/RD,GOCP=G/CP,ROCP=RD/CP,FV=RV/RD-1) PARAMETER(CONT=1000.*CP/G,CONQ=1000.*HVAP/G,CONW=1000./G) PARAMETER(RLAM=150.,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) PARAMETER(DW2MIN=0.0001,DKMIN=1.0,DKMAX=1000.,RIMIN=-100.) PARAMETER(RBCR=0.5,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) PARAMETER(QMIN=1.E-8,XKZO=1.,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) PARAMETER(GAMCRT=3.,GAMCRQ=2.E-3) PARAMETER(IUN=84) DIMENSION DUSFC(IM),DVSFC(IM),DTSFC(IM),DQSFC(IM) DIMENSION A(IM,KM),B(IM,KM),TAU(IM,KM),RTG(IM,KM), 1 U1(IM2,KM),V1(IM2,KM),T1(IM2,KM),Q1(IM2,KM), C 2 Z0M(IM),Z0H(IM),TSEA(IM),QSS(IM),PSTAR(IM),DPHI(IM), 2 TSEA(IM),QSS(IM),PSTAR(IM),DPHI(IM), C 3 SI(KM+1),DEL(KM),CL(KM),SL(KM),SLK(KM), 3 SI(KM+1),DEL(KM),SL(KM),SLK(KM), 4 FM(IM),FH(IM),RBSOIL(IM),CD(IM),CH(IM) C LOCAL ARRAY DIMENSION DZOT( 28 -1),RDZT( 28 -1), 1 BETAW( 384 ),BETAQ( 384 ),BETAT( 384 ), 1 ZI( 384 , 28 +1),ZL( 384 , 28 ),ZL1( 384 ), 2 DKU( 384 , 28 -1),DKT( 384 , 28 -1), 3 AL( 384 , 28 -1),AD( 384 , 28 ),AU( 384 , 28 -1), 4 A1( 384 , 28 ),A2( 384 , 28 ), 5 WSCALE( 384 ),HGAMT( 384 ),HGAMQ( 384 ), 5 KPBL( 384 ),HPBL( 384 ), 6 USTAR( 384 ),SPD1( 384 ),THE1V( 384 ),THERMAL( 384 ), 6 RBDN( 384 ),RBUP( 384 ), 7 HEAT( 384 ),EVAP( 384 ),THESV( 384 ),THE1( 384 ), 7 WSTAR( 384 ), 8 PHIM( 384 ),PHIH( 384 ),slmask( 384 ) LOGICAL PBLFLG( 384 ),SFCFLG( 384 ),STABLE( 384 ) C C----------------------------------------------------------------------- C 601 FORMAT(1X,' MONINP LAT LON STEP HOUR ',3I6,F6.1) 602 FORMAT(1X,' K',' Z',' T',' TH', 1 ' TVH',' Q',' U',' V', 2 ' SP') 603 FORMAT(1X,I5,8F9.1) 604 FORMAT(1X,' SFC',9X,F9.1,18X,F9.1) 605 FORMAT(1X,' K ZL SPD2 THEKV THE1V' 1 ,' THERMAL RBUP') 606 FORMAT(1X,I5,6F8.2) 607 FORMAT(1X,' KPBL HPBL FM FH HGAMT', 1 ' HGAMQ WS USTAR CD CH') 608 FORMAT(1X,I5,9F8.2) 609 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2) 610 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2,' L2 RI T2', 1 ' SR2 ',2F8.2,2E10.2) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C COMPUTE PRELIMINARY VARIABLES C CCC IPRT = 0 CCC IF(IPRT.EQ.1) THEN CCC LATD = 0 CCC LOND = 0 CCC ELSE CCC LATD = 0 CCC LOND = 0 CCC ENDIF C DT = 4. * DELTIM RDT = 1. / DT RDZT1 = GOR * SL(1) / DEL(1) KMPBL = KM / 2 C DO K = 1,KM-1 RDZT(K) = GOR * SI(K+1) / (SL(K) - SL(K+1)) DZOT(K) = LOG(SI(K+1) / SI(K)) / GOR ENDDO C DO I = 1,IM ZI(I,1) = 0. ENDDO DO K = 1, KM - 1 DO I = 1, IM ZI(I,K+1) = ZI(I,K) - T1(I,K) * DZOT(K) ENDDO ENDDO C CCC IF(LAT.EQ.LATD) THEN CCC I = LOND CCC WRITE(IUN,602) CCC DO K = KM-1,1,-1 CCC ZLKP1 = (ZI(I,K) + ZI(I,K+1))/2. CCC THETA = T1(I,K)/SLK(K) CCC THETAV = T1(I,K)/SLK(K)*(1.+FV*MAX(Q1(I,K),QMIN)) CCC SPEED = SQRT(MAX(RCL*(U1(I,K)**2+V1(I,K)**2),1.)) CCC WRITE(IUN,603) K,ZLKP1,T1(I,K)-273.15,THETA,THETAV, CCC 1 Q1(I,K)*1000.,U1(I,K),V1(I,K),SPEED CCC ENDDO CCC WRITE(IUN,604) TSEA(I),QSS(I)*1000. CCC ENDIF C DO I = 1,IM DUSFC(I) = 0. DVSFC(I) = 0. DTSFC(I) = 0. DQSFC(I) = 0. HGAMT(I) = 0. HGAMQ(I) = 0. WSCALE(I) = 0. KPBL(I) = 1 HPBL(I) = ZI(I,2) PBLFLG(I) = .TRUE. SFCFLG(I) = .TRUE. IF(RBSOIL(I).GT.0.0) SFCFLG(I) = .FALSE. ENDDO C DO I = 1,IM BET1 = DT*RDZT1*SPD1(I)/T1(I,1) BETAW(I) = BET1*CD(I) BETAT(I) = BET1*CH(I) BETAQ(I) = DPHI(I)*BETAT(I) ENDDO C DO I = 1,IM ZL1(I) = 0.-(T1(I,1)+TSEA(I))/2.*LOG(SL(1))/GOR USTAR(I) = SQRT(CD(I)*SPD1(I)**2) ENDDO C DO I = 1,IM THESV(I) = TSEA(I)*(1.+FV*MAX(QSS(I),QMIN)) THE1(I) = T1(I,1)/SLK(1) THE1V(I) = THE1(I)*(1.+FV*MAX(Q1(I,1),QMIN)) THERMAL(I) = THE1V(I) DTHE1 = (THE1(I)-TSEA(I)) DQ1 = (MAX(Q1(I,1),QMIN) - MAX(QSS(I),QMIN)) HEAT(I) = -CH(I)*SPD1(I)*DTHE1 EVAP(I) = -CH(I)*SPD1(I)*DQ1 ENDDO C C C COMPUTE THE FIRST GUESS OF PBL HEIGHT C DO I = 1, IM STABLE(I) = .FALSE. ZL(I,1) = ZL1(I) RBUP(I) = RBSOIL(I) ENDDO DO K = 2, KMPBL DO I = 1, IM IF(.NOT.STABLE(I)) THEN RBDN(I) = RBUP(I) ZL(I,K) = ZL(I,K-1) - (T1(I,K)+T1(I,K-1))/2 * & LOG(SL(K)/SL(K-1)) / GOR THEKV = T1(I,K)/SLK(K)*(1.+FV*MAX(Q1(I,K),QMIN)) SPDK2 = MAX(RCL*(U1(I,K)**2+V1(I,K)**2),1.) RBUP(I) = (THEKV-THE1V(I))*(G*ZL(I,K)/THE1V(I))/SPDK2 KPBL(I) = K STABLE(I) = RBUP(I).GT.RBCR ENDIF ENDDO ENDDO C DO I = 1,IM K = KPBL(I) IF(RBDN(I).GE.RBCR) THEN RBINT = 0. ELSEIF(RBUP(I).LE.RBCR) THEN RBINT = 1. ELSE RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) ENDIF HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1)) IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 ENDDO C DO I = 1, IM HOL = MAX(RBSOIL(I)*FM(I)*FM(I)/FH(I),RIMIN) IF(SFCFLG(I)) THEN HOL = MIN(HOL,-ZFMIN) ELSE HOL = MAX(HOL,ZFMIN) ENDIF C HOL = HOL*HPBL(I)/ZL1(I)*SFCFRAC IF(SFCFLG(I)) THEN PHIM(I) = (1.-APHI16*HOL)**(-1./4.) PHIH(I) = (1.-APHI16*HOL)**(-1./2.) ELSE PHIM(I) = (1.+APHI5*HOL) PHIH(I) = PHIM(I) ENDIF WSCALE(I) = USTAR(I)/PHIM(I) WSCALE(I) = MIN(WSCALE(I),USTAR(I)*APHI16) WSCALE(I) = MAX(WSCALE(I),USTAR(I)/APHI5) ENDDO C C COMPUTE THE SURFACE VARIABLES FOR PBL HEIGHT ESTIMATION C UNDER UNSTABLE CONDITIONS C DO I = 1,IM SFLUX = HEAT(I) + EVAP(I)*FV*THE1(I) IF(SFCFLG(I).AND.SFLUX.GT.0.0) THEN HGAMT(I) = MIN(CFAC*HEAT(I)/WSCALE(I),GAMCRT) HGAMQ(I) = MIN(CFAC*EVAP(I)/WSCALE(I),GAMCRQ) if(slmask(i).ne.1) hgamq(i) = 0. VPERT = HGAMT(I) + FV*THE1(I)*HGAMQ(I) VPERT = MIN(VPERT,GAMCRT) THERMAL(I) = THERMAL(I) + MAX(VPERT,0.) HGAMT(I) = MAX(HGAMT(I),0.0) HGAMQ(I) = MAX(HGAMQ(I),0.0) ELSE PBLFLG(I) = .FALSE. ENDIF ENDDO C DO I = 1,IM IF(PBLFLG(I)) THEN KPBL(I) = 1 HPBL(I) = ZI(I,2) ENDIF ENDDO C C ENHANCE THE PBL HEIGHT BY CONSIDERING THE THERMAL C DO I = 1, IM IF(PBLFLG(I)) THEN STABLE(I) = .FALSE. RBUP(I) = RBSOIL(I) ENDIF ENDDO DO K = 2, KMPBL DO I = 1, IM IF(.NOT.STABLE(I).AND.PBLFLG(I)) THEN RBDN(I) = RBUP(I) ZL(I,K) = ZL(I,K-1) - (T1(I,K)+T1(I,K-1))/2 * & LOG(SL(K)/SL(K-1)) / GOR THEKV = T1(I,K)/SLK(K)*(1.+FV*MAX(Q1(I,K),QMIN)) SPDK2 = MAX(RCL*(U1(I,K)**2+V1(I,K)**2),1.) RBUP(I) = (THEKV-THERMAL(I))*(G*ZL(I,K)/THE1V(I))/SPDK2 KPBL(I) = K STABLE(I) = RBUP(I).GT.RBCR ENDIF ENDDO ENDDO C DO I = 1,IM IF(PBLFLG(I)) THEN K = KPBL(I) IF(RBDN(I).GE.RBCR) THEN RBINT = 0. ELSEIF(RBUP(I).LE.RBCR) THEN RBINT = 1. ELSE RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) ENDIF HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1)) IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE. ENDIF ENDDO C C COMPUTE DIFFUSION COEFFICIENTS BELOW PBL C DO K = 1, KMPBL DO I = 1, IM IF(KPBL(I).GT.K) THEN PRNUM = (PHIH(I)/PHIM(I)+CFAC*VK*.1) PRNUM = MIN(PRNUM,PRMAX) PRNUM = MAX(PRNUM,PRMIN) ZFAC = MAX((1.-(ZI(I,K+1)-ZL1(I))/ 1 (HPBL(I)-ZL1(I))), ZFMIN) DKU(I,K) = XKZO + WSCALE(I)*VK*ZI(I,K+1) 1 *ZFAC**PFAC DKT(I,K) = DKU(I,K)/PRNUM DKU(I,K) = MIN(DKU(I,K),DKMAX) DKU(I,K) = MAX(DKU(I,K),DKMIN) DKT(I,K) = MIN(DKT(I,K),DKMAX) DKT(I,K) = MAX(DKT(I,K),DKMIN) ENDIF ENDDO ENDDO C C COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) C DO K = 1, KM-1 DO I = 1, IM IF(K.GE.KPBL(I)) THEN TI =0.5*(T1(I,K)+T1(I,K+1)) RDZ =RDZT(K)/TI DW2 =RCL*((U1(I,K)-U1(I,K+1))**2+(V1(I,K)-V1(I,K+1))**2) SHR2 =MAX(DW2,DW2MIN)*RDZ**2 TVD =T1(I,K)*(1.+FV*MAX(Q1(I,K),QMIN)) TVU =T1(I,K+1)*(1.+FV*MAX(Q1(I,K+1),QMIN)) BVF2 =G*(GOCP+RDZ*(TVU-TVD))/TI RI =MAX(BVF2/SHR2,RIMIN) ZK =VK*ZI(I,K+1) RL2 =(ZK*RLAM/(RLAM+ZK))**2 DK =RL2*SQRT(SHR2) IF(RI.LT.0.) THEN ! UNSTABLE REGIME SRI = SQRT(-RI) DKU(I,K) = XKZO + DK*(1+8.*(-RI)/(1+1.746*SRI)) DKT(I,K) = XKZO + DK*(1+8.*(-RI)/(1+1.286*SRI)) ELSE ! STABLE REGIME DKT(I,K) = XKZO + DK/(1+5.*RI)**2 PRNUM = 1.0 + 2.1*RI PRNUM = MIN(PRNUM,PRMAX) DKU(I,K) = (DKT(I,K)-XKZO)*PRNUM + XKZO ENDIF C DKU(I,K) = MIN(DKU(I,K),DKMAX) DKU(I,K) = MAX(DKU(I,K),DKMIN) DKT(I,K) = MIN(DKT(I,K),DKMAX) DKT(I,K) = MAX(DKT(I,K),DKMIN) C CCC IF(I.EQ.LOND.AND.LAT.EQ.LATD) THEN CCC PRNUM = DKU(I,K)/DKT(I,K) CCC WRITE(IUN,610) K,PRNUM,DKT(I,K),DKU(I,K),RL2,RI, CCC 1 BVF2,SHR2 CCC ENDIF C ENDIF ENDDO ENDDO C C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE C DO I=1,IM AD(I,1) = 1. A1(I,1) = T1(I,1)-BETAT(I)*(T1(I,1)/SLK(1)-TSEA(I)) A2(I,1) = Q1(I,1)-BETAQ(I)*(MAX(Q1(I,1),QMIN)-MAX(QSS(I),QMIN)) ENDDO C DO K = 1,KM-1 DTODSD = DT/DEL(K) DTODSU = DT/DEL(K+1) DSIG = SL(K)-SL(K+1) DO I = 1,IM RDZ = RDZT(K)*2./(T1(I,K)+T1(I,K+1)) IF(PBLFLG(I).AND.K.LT.KPBL(I)) THEN DSDZT = DSIG*DKT(I,K)*RDZ*(GOCP-HGAMT(I)/HPBL(I)) DSDZQ = DSIG*DKT(I,K)*RDZ*(-HGAMQ(I)/HPBL(I)) A2(I,K) = A2(I,K)+DTODSD*DSDZQ A2(I,K+1) = Q1(I,K+1)-DTODSU*DSDZQ ELSE DSDZT = DSIG*DKT(I,K)*RDZ*(GOCP) A2(I,K+1) = Q1(I,K+1) ENDIF DSDZ2 = DSIG*DKT(I,K)*RDZ*RDZ AU(I,K) = -DTODSD*DSDZ2 AL(I,K) = -DTODSU*DSDZ2 AD(I,K) = AD(I,K)-AU(I,K) AD(I,K+1) = 1.-AL(I,K) A1(I,K) = A1(I,K)+DTODSD*DSDZT A1(I,K+1) = T1(I,K+1)-DTODSU*DSDZT ENDDO ENDDO C C SOLVE TRIDIAGONAL PROBLEM FOR HEAT AND MOISTURE C CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2) C C RECOVER TENDENCIES OF HEAT AND MOISTURE C DO K = 1,KM DO I = 1,IM TTEND = (A1(I,K)-T1(I,K))*RDT QTEND = (A2(I,K)-Q1(I,K))*RDT TAU(I,K) = TAU(I,K)+TTEND RTG(I,K) = RTG(I,K)+QTEND DTSFC(I) = DTSFC(I)+CONT*DEL(K)*PSTAR(I)*TTEND DQSFC(I) = DQSFC(I)+CONQ*DEL(K)*PSTAR(I)*QTEND ENDDO ENDDO C C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR MOMENTUM C DO I = 1,IM AD(I,1) = 1.+BETAW(I) A1(I,1) = U1(I,1) A2(I,1) = V1(I,1) ENDDO C DO K = 1,KM-1 DTODSD = DT/DEL(K) DTODSU = DT/DEL(K+1) DSIG = SL(K)-SL(K+1) DO I=1,IM RDZ = RDZT(K)*2./(T1(I,K)+T1(I,K+1)) DSDZ2 = DSIG*DKU(I,K)*RDZ*RDZ AU(I,K) = -DTODSD*DSDZ2 AL(I,K) = -DTODSU*DSDZ2 AD(I,K) = AD(I,K)-AU(I,K) AD(I,K+1)= 1.-AL(I,K) A1(I,K+1)= U1(I,K+1) A2(I,K+1)= V1(I,K+1) ENDDO ENDDO C C SOLVE TRIDIAGONAL PROBLEM FOR MOMENTUM C CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2) C C RECOVER TENDENCIES OF MOMENTUM C CONWRC = CONW*SQRT(RCL) DO K = 1,KM DO I = 1,IM UTEND = (A1(I,K)-U1(I,K))*RDT VTEND = (A2(I,K)-V1(I,K))*RDT B(I,K)= B(I,K)+UTEND A(I,K)= A(I,K)+VTEND DUSFC(I) = DUSFC(I)+CONWRC*DEL(K)*PSTAR(I)*UTEND DVSFC(I) = DVSFC(I)+CONWRC*DEL(K)*PSTAR(I)*VTEND ENDDO ENDDO C RETURN END CFPP$ NOCONCUR R CFPP$ EXPAND(FPKAP,FTDP,FTLCL,FTHE,FTMA) C----------------------------------------------------------------------- SUBROUTINE MSTADB(IMX2,KMX,K1,K2,SL,SLK,PS,TENV,QENV, & KLCL,KBOT,KTOP,TCLD,QCLD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MSTADB COMPUTE MOIST ADIABATIC CLOUD SOUNDINGS C C AUTHOR: N PHILLIPS DATE: NOV 1983 C C ABSTRACT: ATMOSPHERIC COLUMNS OF TEMPERATURE AND SPECIFIC HUMIDITY C ARE EXAMINED BY THIS ROUTINE FOR CONDITIONAL INSTABILITY. C THE TEST PARCEL IS CHOSEN FROM THE LAYER BETWEEN LAYERS K1 AND K2 C THAT HAS THE WARMEST POTENTIAL WET-BULB TEMPERATURE. C EXCESS CLOUD TEMPERATURES AND SPECIFIC HUMIDITIES ARE RETURNED C WHERE THE LIFTED PARCEL IS FOUND TO BE BUOYANT. C FAST INLINABLE FUNCTIONS ARE INVOKED TO COMPUTE C DEWPOINT AND LIFTING CONDENSATION LEVEL TEMPERATURES, C EQUIVALENT POTENTIAL TEMPERATURE AT THE LCL, AND C TEMPERATURE AND SPECIFIC HUMIDITY OF THE ASCENDING PARCEL. C C PROGRAM HISTORY LOG: C 83-11 PHILLIPS C 91-05-07 IREDELL ARGUMENTS CHANGED, CODE TIDIED C C USAGE: CALL MSTADB(IM,KM,K1,K2,SL,SLK,PS,TENV,QENV, C & KLCL,KBOT,KTOP,TCLD,QCLD) C C INPUT ARGUMENT LIST: C IM - INTEGER NUMBER OF ATMOSPHERIC COLUMNS C KM - INTEGER NUMBER OF SIGMA LEVELS IN A COLUMN C K1 - INTEGER LOWEST LEVEL FROM WHICH A PARCEL CAN ORIGINATE C K2 - INTEGER HIGHEST LEVEL FROM WHICH A PARCEL CAN ORIGINATE C SL - REAL (KM) SIGMA VALUES C SLK - REAL (KM) SIGMA VALUES TO THE KAPPA C PS - REAL (IM) SURFACE PRESSURE IN KILOPASCALS (CB) C TENV - REAL (IM,KM) ENVIRONMENT TEMPERATURES C QENV - REAL (IM,KM) ENVIRONMENT SPECIFIC HUMIDITIES C C OUTPUT ARGUMENT LIST: C KLCL - INTEGER (IM) LEVEL JUST ABOVE LCL (KM+1 IF NO LCL) C KBOT - INTEGER (IM) LEVEL JUST ABOVE CLOUD BOTTOM C KTOP - INTEGER (IM) LEVEL JUST BELOW CLOUD TOP C - NOTE THAT KBOT(I) GT KTOP(I) IF NO CLOUD. C TCLD - REAL (IM,KM) OF EXCESS CLOUD TEMPERATURES. C (PARCEL T MINUS ENVIRON T, OR 0. WHERE NO CLOUD) C QCLD - REAL (IM,KM) OF EXCESS CLOUD SPECIFIC HUMIDITIES. C (PARCEL Q MINUS ENVIRON Q, OR 0. WHERE NO CLOUD) C C SUBPROGRAMS CALLED: C FPKAP - FUNCTION TO COMPUTE PRESSURE TO THE KAPPA POWER C FTDP - FUNCTION TO COMPUTE DEWPOINT TEMPERATURE C FTLCL - FUNCTION TO COMPUTE LCL TEMPERATURE C FTHE - FUNCTION TO COMPUTE EQUIVALENT POTENTIAL TEMPERATURE C FTMA - FUNCTION TO COMPUTE PARCEL TEMPERATURE AND HUMIDITY C C REMARKS: ALL FUNCTIONS ARE INLINED BY FPP. C NONSTANDARD AUTOMATIC ARRAYS ARE USED. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ DIMENSION SL(KMX),SLK(KMX),PS(IMX2),TENV(IMX2,KMX),QENV(IMX2,KMX), & KLCL(IMX2),KBOT(IMX2),KTOP(IMX2),TCLD(IMX2,KMX),QCLD(IMX2,KMX) C PHYSICAL PARAMETERS PARAMETER(RD= 2.8705E+2 ,RV= 4.6150E+2 ) PARAMETER(EPS=RD/RV,EPSM1=RD/RV-1.,FTV=RV/RD-1.) C LOCAL ARRAYS DIMENSION PSK( 384 ),SLKMA( 384 ),THEMA( 384 ) C----------------------------------------------------------------------- C DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2. C COMPUTE ITS LIFTING CONDENSATION LEVEL. DO I=1,IMX2 PSK(I)=FPKAP(PS(I)) SLKMA(I)=0. THEMA(I)=0. ENDDO DO K=K1,K2 DO I=1,IMX2 PV=SL(K)*PS(I)*QENV(I,K)/(EPS-EPSM1*QENV(I,K)) TDPD=TENV(I,K)-FTDP(PV) IF(TDPD.GT.0.) THEN TLCL=FTLCL(TENV(I,K),TDPD) SLKLCL=SLK(K)*TLCL/TENV(I,K) ELSE TLCL=TENV(I,K) SLKLCL=SLK(K) ENDIF THELCL=FTHE(TLCL,SLKLCL*PSK(I)) IF(THELCL.GT.THEMA(I)) THEN SLKMA(I)=SLKLCL THEMA(I)=THELCL ENDIF ENDDO ENDDO C----------------------------------------------------------------------- C SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP C THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT. DO I=1,IMX2 KLCL(I)=KMX+1 KBOT(I)=KMX+1 KTOP(I)=0 ENDDO DO K=1,KMX DO I=1,IMX2 TCLD(I,K)=0. QCLD(I,K)=0. ENDDO ENDDO DO K=K1,KMX DO I=1,IMX2 IF(SLK(K).LE.SLKMA(I)) THEN KLCL(I)=MIN(KLCL(I),K) TMA=FTMA(THEMA(I),SLK(K)*PSK(I),QMA) TVCLD=TMA*(1.+FTV*QMA) TVENV=TENV(I,K)*(1.+FTV*QENV(I,K)) IF(TVCLD.GT.TVENV) THEN KBOT(I)=MIN(KBOT(I),K) KTOP(I)=MAX(KTOP(I),K) TCLD(I,K)=TMA-TENV(I,K) QCLD(I,K)=QMA-QENV(I,K) ENDIF ENDIF ENDDO ENDDO C----------------------------------------------------------------------- RETURN END CFPP$ NOCONCUR R CFPP$ EXPAND(FPVS,FUNCDF,FUNCKT,KTSOIL,TWLT,THSAT) SUBROUTINE PROGTM(IMX2,KMX,PS,U1,V1,T1,Q1,SHELEG,TSKIN,QSURF, & SMC,STC,DM,SOILTYP,SIGMAF,CANOPY, & SLRAD,SNOWMT,SNOWEV,DELT,Z0RL,PLANTR,TG3, & GFLUX,F10M,U10M,V10M,T2M,Q2M,ZSOIL, & CM, CH, RB,RHSCNPY,RHSMC,AIM,BIM,CIM, & RCL,SL1,SLK1,SLIMSK,INISTP,LAT, & DRAIN,EVAP,HFLX,RNET,EP,COWAVE,FM,FH,WIND) C CA IS THE VON KARMAN CONSTANT PARAMETER (CHARNOCK=.014,CA=.4) PARAMETER (RD= 2.8705E+2 ,RV= 4.6150E+2 ,CP= 1.0046E+3 ,G= 9.8000E 1+0 ,SIGMA= 5.6730E-8 ) PARAMETER (EPS=RD/RV,HVAP= 2.5000E+6 ,HFUS= 3.3358E+5 ) PARAMETER (RVRDM1= 0.6077338 ,T0C= 2.7315E+2 ,EPSM1=EPS-1.) PARAMETER (ALPHA=5.,A0=-3.975,A1=12.32,B1=-7.755,B2=6.041) PARAMETER (A0P=-7.941,A1P=24.75,B1P=-8.705,B2P=7.899,VIS=1.4E-5) PARAMETER (AA1=-1.076,BB1=.7045,CC1=-.05808) PARAMETER (BB2=-.1954,CC2=.009999) PARAMETER (ELOCP=HVAP/CP,DFSNOW=.31,CH2O=4.2E6,CSOIL=1.26E6) PARAMETER (SCANOP=2.,CFACTR=.5,ZBOT=-3.,TGICE=271.2) PARAMETER (CICE=1880.*917.) PARAMETER (RHOH2O=1000.,CONVRAD= 4.1855E+0 *1.E4/60.) PARAMETER (CTFIL1=.5,CTFIL2=1.-CTFIL1) PARAMETER (RNU=1.51E-5,ARNU=.135*RNU) INTEGER SOILTYP REAL KT1, KT2, KTSOIL LOGICAL FLAG, FLAGSNW C PASSING ARRAY DIMENSION PS(IMX2),U1(IMX2),V1(IMX2),T1(IMX2),Q1(IMX2) DIMENSION SHELEG(IMX2),SNOWMT(IMX2),SNOWEV(IMX2) DIMENSION CM(IMX2),CH(IMX2) DIMENSION TSKIN(IMX2),QSURF(IMX2),DM(IMX2),SLRAD(IMX2) DIMENSION SMC(IMX2,KMX),STC(IMX2,KMX),TG3(IMX2),CANOPY(IMX2) DIMENSION Z0RL(IMX2),PLANTR(IMX2),SOILTYP(IMX2),GFLUX(IMX2) DIMENSION U10M(IMX2),V10M(IMX2),T2M(IMX2),Q2M(IMX2) DIMENSION SLIMSK(IMX2),RHSCNPY(IMX2),RHSMC(IMX2,KMX),RB(IMX2) DIMENSION AIM(IMX2,KMX),BIM(IMX2,KMX),CIM(IMX2,KMX) DIMENSION F10M(IMX2),DRAIN(IMX2),ZSOIL(IMX2,KMX),SIGMAF(IMX2) DIMENSION EVAP(IMX2),HFLX(IMX2),RNET(IMX2),EP(IMX2) DIMENSION FM(IMX2),FH(IMX2),WIND(IMX2) C C PARAMETER(LM= 384 ,MM= 2 ) C LOCAL ARRAY DIMENSION RS( 384 ),PSURF( 384 ),THETA1( 384 ) DIMENSION TV1( 384 ),TVS( 384 ),Z1( 384 ),THV1( 384 ) DIMENSION RHO( 384 ),QS1( 384 ),QSS( 384 ),SNOWD( 384 ) DIMENSION ETPFAC( 384 ),USTAR( 384 ),TSURF( 384 ) DIMENSION Q0( 384 ),CQ( 384 ),STSOIL( 384 , 28 ),DEW( 384 ) DIMENSION EDIR( 384 ),ET( 384 , 28 ),EC( 384 ) DIMENSION Z0MAX( 384 ),ZTMAX( 384 ),DTV( 384 ),ADTV( 384 ) DIMENSION FM10( 384 ),FH2( 384 ),HLINF( 384 ) DIMENSION HL1( 384 ),PM( 384 ),PH( 384 ) DIMENSION HL110( 384 ),HL12( 384 ),RCAP( 384 ),RSMALL( 384 ) DIMENSION PM10( 384 ),PH2( 384 ),OLINF( 384 ),RCH( 384 ) DIMENSION DFT0( 384 ),T12( 384 ),T14( 384 ) DIMENSION DELTA( 384 ),FLAG( 384 ),TREF( 384 ) DIMENSION TWILT( 384 ),DF1( 384 ),ETP( 384 ) DIMENSION KT1( 384 ),FX( 384 ),GX( 384 ),CANFAC( 384 ) DIMENSION SMCZ( 384 ),DMDZ( 384 ),DDZ( 384 ),DMDZ2( 384 ) DIMENSION DDZ2( 384 ),DF2( 384 ),KT2( 384 ) DIMENSION XX( 384 ),YY( 384 ),ZZ( 384 ),DTDZ2( 384 ),DFT2( 384 ) DIMENSION DTDZ1( 384 ),DFT1( 384 ),HCPCT( 384 ) DIMENSION AI( 384 , 28 ),BI( 384 , 28 ),CI( 384 , 28 ) DIMENSION RHSTC( 384 , 28 ) DIMENSION FACTSNW( 384 ),Z0( 384 ),SLWD( 384 ),FLAGSNW( 384 ) DIMENSION TERM1( 384 ), TERM2( 384 ), PARTLND( 384 ) DIMENSION RESTAR( 384 ), RAT( 384 ) LATD = 42 LOND = 11 DELT2 = DELT * 2. IM = IMX2 KM = KMX C C ESTIMATE SIGMA ** K AT 2 M C SIG2K = 1. - 4. * G * 2. / (CP * 280.) C C INITIALIZE VARIABLES. ALL UNITS ARE SUPPOSEDLY M.K.S. UNLESS SPECIFIE C PSURF IS IN PASCALS C WIND IS WIND SPEED, THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 C RHO IS DENSITY, QS1 IS SAT. HUM. AT LEVEL1 AND QSS IS SAT. HUM. AT C SURFACE C CONVERT SLRAD TO THE CIVILIZED UNIT FROM LANGLEY MINUTE-1 K-4 C SURFACE ROUGHNESS LENGTH IS CONVERTED TO M FROM CM C XRCL = SQRT(RCL) DO I = 1, IM PSURF(I) = 1000. * PS(I) SLWD(I) = SLRAD(I) * CONVRAD C-DBG if(i.eq.23) then C-DBG write(6,12121) convrad C-DBG write(6,12121) slrad(i) C-DBG write(6,12121) slwd(i) C-DBG endif WIND(I) = XRCL * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) C WIND(I) = MAX(WIND(I),1.E-6) WIND(I) = MAX(WIND(I),1.) Q0(I) = MAX(Q1(I),1.E-9) TSURF(I) = TSKIN(I) THETA1(I) = T1(I) / SLK1 C IF(SLIMSK(I).EQ.1..AND.THETA1(I).LT.TSURF(I)) THEN C WIND(I)=MAX(WIND(I),1.) C ENDIF TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) THV1(I) = THETA1(I) * (1. + RVRDM1 * Q0(I)) TVS(I) = TSURF(I) * (1. + RVRDM1 * Q0(I)) RHO(I) = (SL1 * PSURF(I)) / (RD * TV1(I)) QS1(I) = 1000. * FPVS(T1(I)) QS1(I) = EPS * QS1(I) / (SL1 * PSURF(I) + EPSM1 * QS1(I)) QS1(I) = MAX(QS1(I), 1.E-8) QSS(I) = 1000. * FPVS(TSURF(I)) QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) RS(I) = PLANTR(I) Z0(I) = .01 * Z0RL(I) CANOPY(I)= MAX(CANOPY(I),0.) DM(I) = 1. FACTSNW(I) = 10. IF(SLIMSK(I).EQ.2.) FACTSNW(I) = 3. C C SNOW DEPTH IN WATER EQUIVALENT IS CONVERTED FROM MM TO M UNIT C SNOWD(I) = SHELEG(I) / 1000. FLAGSNW(I) = .FALSE. C C WHEN SNOW DEPTH IS LESS THAN 1 MM, A PATCHY SNOW IS ASSUMED AND C SOIL IS ALLOWED TO INTERACT WITH THE ATMOSPHERE. C WE SHOULD EVENTUALLY MOVE TO A LINEAR COMBINATION OF SOIL AND C SNOW UNDER THE CONDITION OF PATCHY SNOW. C IF(SNOWD(I).GT..001.OR.SLIMSK(I).EQ.2) RS(I) = 0. IF(SNOWD(I).GT..001) FLAGSNW(I) = .TRUE. ENDDO C IF(LAT.EQ.LATD) THEN C I = LOND C PRINT *, ' WIND,TV1,TVS,Q1,QS1,SNOW,SLIMSK=', C & WIND(I),TV1(I),TVS(I),Q1(I),QS1(I),SNOWD(I),SLIMSK(I) C PRINT *, ' SLRAD =', SLRAD(I) C ENDIF DO I = 1, IM IF(SLIMSK(I).EQ.0.) THEN ZSOIL(I,1) = 0. ELSEIF(SLIMSK(I).EQ.1.) THEN ZSOIL(I,1) = -.10 ELSE ZSOIL(I,1) = -3. / KM ENDIF ENDDO 100 CONTINUE DO K = 2, KM DO I = 1, IM IF(SLIMSK(I).EQ.0.) THEN ZSOIL(I,K) = 0. ELSEIF(SLIMSK(I).EQ.1.) THEN ZSOIL(I,K) = ZSOIL(I,K-1) & + (-2. - ZSOIL(I,1)) / (KM - 1) ELSE ZSOIL(I,K) = - 3. * FLOAT(K) / FLOAT(KM) ENDIF ENDDO ENDDO DO I = 1, IM Z1(I) = -RD * TV1(I) * LOG(SL1) / G DRAIN(I) = 0. ENDDO DO K = 1, KM DO I = 1, IM ET(I,K) = 0. RHSMC(I,K) = 0. AIM(I,K) = 0. BIM(I,K) = 1. CIM(I,K) = 0. STSOIL(I,K) = STC(I,K) ENDDO ENDDO DO I = 1, IM EDIR(I) = 0. EC(I) = 0. EVAP(I) = 0. EP(I) = 0. SNOWMT(I) = 0. SNOWEV(I) = 0. GFLUX(I) = 0. RHSCNPY(I) = 0. FX(I) = 0. ETPFAC(I) = 0. CANFAC(I) = 0. ENDDO C C COMPUTE STABILITY DEPENDENT EXCHANGE COEFFICIENTS C C THIS PORTION OF THE CODE IS PRESENTLY SUPPRESSED C DO I = 1, IM C IF(INISTP.EQ.1.AND.SLIMSK(I).NE.0.) THEN USTAR(I) = .1 * WIND(I) C ENDIF C IF(INISTP.EQ.1.AND.SLIMSK(I).EQ.0.) THEN IF(SLIMSK(I).EQ.0.) THEN USTAR(I) = SQRT(G * Z0(I) / CHARNOCK) ENDIF ENDDO C C COMPUTE STABILITY INDICES (RB AND HLINF) C DO I = 1, IM Z0MAX(I) = MIN(Z0(I),1. * Z1(I)) ZTMAX(I) = Z0MAX(I) IF(SLIMSK(I).EQ.0.) THEN RESTAR(I) = USTAR(I) * Z0MAX(I) / VIS RESTAR(I) = MAX(RESTAR(I),.000001) RESTAR(I) = LOG(RESTAR(I)) RESTAR(I) = MIN(RESTAR(I),5.) RESTAR(I) = MAX(RESTAR(I),-5.) RAT(I) = AA1 + BB1 * RESTAR(I) + CC1 * RESTAR(I) ** 2 RAT(I) = RAT(I) / (1. + BB2 * RESTAR(I) & + CC2 * RESTAR(I) ** 2) ZTMAX(I) = Z0MAX(I) * EXP(-RAT(I)) ENDIF ENDDO DO I = 1, IM DTV(I) = THV1(I) - TVS(I) ADTV(I) = ABS(DTV(I)) ADTV(I) = MAX(ADTV(I),.001) DTV(I) = SIGN(1.,DTV(I)) * ADTV(I) RB(I) = G * DTV(I) * Z1(I) / (.5 * (THV1(I) + TVS(I)) & * WIND(I) * WIND(I)) RB(I) = MAX(RB(I),-5000.) FM(I) = LOG((Z0MAX(I)+Z1(I)) / Z0MAX(I)) FH(I) = LOG((ZTMAX(I)+Z1(I)) / ZTMAX(I)) FM10(I) = LOG((Z0MAX(I)+10.) / Z0MAX(I)) FH2(I) = LOG((ZTMAX(I)+2.) / ZTMAX(I)) HLINF(I) = RB(I) * FM(I) * FM(I) / FH(I) ENDDO C C STABLE CASE C DO I = 1, IM IF(DTV(I).GE.0.) THEN HL1(I) = HLINF(I) ENDIF IF(DTV(I).GE.0..AND.HLINF(I).GT..25) THEN HL0INF = Z0MAX(I) * HLINF(I) / Z1(I) HLTINF = ZTMAX(I) * HLINF(I) / Z1(I) AA = SQRT(1. + 4. * ALPHA * HLINF(I)) AA0 = SQRT(1. + 4. * ALPHA * HL0INF) BB = AA BB0 = SQRT(1. + 4. * ALPHA * HLTINF) PM(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) PH(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) FMS = FM(I) - PM(I) FHS = FH(I) - PH(I) HL1(I) = FMS * FMS * RB(I) / FHS ENDIF ENDDO C C SECOND ITERATION C DO I = 1, IM IF(DTV(I).GE.0.) THEN HL0 = Z0MAX(I) * HL1(I) / Z1(I) HLT = ZTMAX(I) * HL1(I) / Z1(I) AA = SQRT(1. + 4. * ALPHA * HL1(I)) AA0 = SQRT(1. + 4. * ALPHA * HL0) BB = AA BB0 = SQRT(1. + 4. * ALPHA * HLT) PM(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) PH(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) HL110(I) = HL1(I) * 10. / Z1(I) AA = SQRT(1. + 4. * ALPHA * HL110(I)) PM10(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) HL12(I) = HL1(I) * 2. / Z1(I) C AA = SQRT(1. + 4. * ALPHA * HL12(I)) BB = SQRT(1. + 4. * ALPHA * HL12(I)) PH2(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) ENDIF ENDDO 200 CONTINUE C C UNSTABLE CASE C C C CHECK FOR UNPHYSICAL OBUKHOV LENGTH C DO I = 1, IM IF(DTV(I).LT.0.) THEN OLINF(I) = Z1(I) / HLINF(I) IF(ABS(OLINF(I)).LE.50. * Z0MAX(I)) THEN HLINF(I) = -Z1(I) / (50. * Z0MAX(I)) ENDIF ENDIF ENDDO C C GET PM AND PH C DO I = 1, IM IF(DTV(I).LT.0..AND.HLINF(I).GE.-.5) THEN HL1(I) = HLINF(I) PM(I) = (A0 + A1 * HL1(I)) * HL1(I) & / (1. + B1 * HL1(I) + B2 * HL1(I) * HL1(I)) PH(I) = (A0P + A1P * HL1(I)) * HL1(I) & / (1. + B1P * HL1(I) + B2P * HL1(I) * HL1(I)) HL110(I) = HL1(I) * 10. / Z1(I) PM10(I) = (A0 + A1 * HL110(I)) * HL110(I) & / (1. + B1 * HL110(I) + B2 * HL110(I) * HL110(I)) HL12(I) = HL1(I) * 2. / Z1(I) PH2(I) = (A0P + A1P * HL12(I)) * HL12(I) & / (1. + B1P * HL12(I) + B2P * HL12(I) * HL12(I)) ENDIF IF(DTV(I).LT.0.AND.HLINF(I).LT.-.5) THEN HL1(I) = -HLINF(I) PM(I) = LOG(HL1(I)) + 2. * HL1(I) ** (-.25) - .8776 PH(I) = LOG(HL1(I)) + .5 * HL1(I) ** (-.5) + 1.386 HL110(I) = HL1(I) * 10. / Z1(I) PM10(I) = LOG(HL110(I)) + 2. * HL110(I) ** (-.25) - .8776 HL12(I) = HL1(I) * 2. / Z1(I) PH2(I) = LOG(HL12(I)) + .5 * HL12(I) ** (-.5) + 1.386 ENDIF ENDDO C C FINISH THE EXCHANGE COEFFICIENT COMPUTATION TO PROVIDE FM AND FH C DO I = 1, IM FM(I) = FM(I) - PM(I) FH(I) = FH(I) - PH(I) FM10(I) = FM10(I) - PM10(I) FH2(I) = FH2(I) - PH2(I) CM(I) = CA * CA / (FM(I) * FM(I)) CH(I) = CA * CA / (FM(I) * FH(I)) CQ(I) = CH(I) USTAR(I) = SQRT(CM(I) * WIND(I) * WIND(I)) ENDDO C C UPDATE Z0 OVER OCEAN C IF(INISTP.LT.2.AND.COWAVE.LE.0.) THEN DO I = 1, IM IF(SLIMSK(I).EQ.0.) THEN Z0(I) = (CHARNOCK / G) * USTAR(I) ** 2 C NEW IMPLEMENTATION OF Z0 C CC = USTAR(I) * Z0(I) / RNU C PP = CC / (1. + CC) C FF = G * ARNU / (CHARNOCK * USTAR(I) ** 3) C Z0(I) = ARNU / (USTAR(I) * FF ** PP) Z0(I) = MIN(Z0(I),.1) Z0(I) = MAX(Z0(I),1.E-7) Z0RL(I) = 100. * Z0(I) ENDIF ENDDO ENDIF C C RCP = RHO CP CH V C DO I = 1, IM RCH(I) = RHO(I) * CP * CH(I) * WIND(I) ENDDO C C SENSIBLE AND LATENT HEAT FLUX OVER OPEN WATER C DO I = 1, IM IF(SLIMSK(I).EQ.0.) THEN EVAP(I) = ELOCP * RCH(I) * (QSS(I) - Q0(I)) DM(I) = 1. QSURF(I) = QSS(I) ENDIF ENDDO C-DBG print *,'EVAP over open water in PROGTM' C-DBG call maxmin(EVAP,im,1,im,1,1) C-DBG print *,'ELOCP=',ELOCP C-DBG print *,'RCH PROGTM' C-DBG call maxmin(RCH,im,1,im,1,1) C-DBG print *,'QSS PROGTM' C-DBG call maxmin(QSS,im,1,im,1,1) C-DBG print *,'Q0 PROGTM' C-DBG call maxmin(Q0,im,1,im,1,1) C C COMPUTE SOIL/SNOW/ICE HEAT FLUX IN PREPARATION FOR SURFACE ENERGY C BALANCE CALCULATION C DO I = 1, IM GFLUX(I) = 0. IF(SLIMSK(I).EQ.1.) THEN C DFT0(I) = KTSOIL(SMC(I,1),SOILTYP(I)) SMCZ(I) = .5 * (SMC(I,1) + .20) DFT0(I) = KTSOIL(SMCZ(I),SOILTYP(I)) ELSEIF(SLIMSK(I).EQ.2.) THEN C DF FOR ICE IS TAKEN FROM MAYKUT AND UNTERSTEINER C DF IS IN SI UNIT OF W K-1 M-1 DFT0(I) = 2.2 ENDIF ENDDO 300 CONTINUE DO I = 1, IM IF(SLIMSK(I).NE.0.) THEN C IF(SNOWD(I).GT..001) THEN IF(FLAGSNW(I)) THEN C C WHEN SNOW COVERED, GROUND HEAT FLUX COMES FROM SNOW C TFLX = MIN(T1(I), TSURF(I)) GFLUX(I) = -DFSNOW * (TFLX - STSOIL(I,1)) & / (FACTSNW(I) * MAX(SNOWD(I),.001)) ELSE GFLUX(I) = DFT0(I) * (STSOIL(I,1) - TSURF(I)) & / (-.5 * ZSOIL(I,1)) ENDIF GFLUX(I) = MAX(GFLUX(I),-200.) GFLUX(I) = MIN(GFLUX(I),+200.) ENDIF ENDDO DO I = 1, IM FLAG(I) = SLIMSK(I).NE.0. PARTLND(I) = 1. IF(SNOWD(I).GT.0..AND.SNOWD(I).LE..001) THEN PARTLND(I) = 1. - SNOWD(I) / .001 ENDIF ENDDO C C COMPUTE POTENTIAL EVAPORATION FOR LAND AND SEA ICE C DO I = 1, IM IF(FLAG(I)) THEN T12(I) = T1(I) * T1(I) T14(I) = T12(I) * T12(I) C C RCAP = FNET - SIGMA T**4 + GFLX - RHO CP CH V (T1-THETA1) C RCAP(I) = -SLWD(I) - SIGMA * T14(I) + GFLUX(I) & - RCH(I) * (T1(I) - THETA1(I)) C-DBG if(i.eq.23) then C-DBG write(6,12121) slwd(i) C-DBG write(6,12121) sigma C-DBG write(6,12121) t14(i) C-DBG write(6,12121) gflux(i) C-DBG write(6,12121) rch(i) C-DBG write(6,12121) t1(i) C-DBG write(6,12121) theta1(i) C-DBG write(6,12121) rcap(i) 12121 format(E35.25) C-DBG endif C C RSMALL = 4 SIGMA T**3 / RCH + 1 C RSMALL(I) = 4. * SIGMA * T1(I) * T12(I) / RCH(I) + 1. C C DELTA = L / CP * DQS/DT C DELTA(I) = ELOCP * EPS * HVAP * QS1(I) / (RD * T12(I)) C C POTENTIAL EVAPOTRANSPIRATION ( WATTS / M**2 ) AND C POTENTIAL EVAPORATION C TERM1(I) = ELOCP * RSMALL(I) * RCH(I)*(QS1(I)-Q0(I)) TERM2(I) = RCAP(I) * DELTA(I) EP(I) = (ELOCP * RSMALL(I) * RCH(I) * (QS1(I) - Q0(I)) & + RCAP(I) * DELTA(I)) ETP(I) = EP(I) / & (RSMALL(I) * (1. + RS(I) * WIND(I) * CH(I)) & + DELTA(I)) EP(I) = EP(I) / (RSMALL(I) + DELTA(I)) ENDIF ENDDO C C-DBG print *,'elocp=',elocp C-DBG print *,'eps=',eps C-DBG print *,'hvap=',hvap C-DBG print *,'rd=',rd C-DBG print *,'sigma=',sigma C-DBG print *,'theta1 in progtm' C-DBG call maxmin(theta1,im,1,im,1,1) C-DBG print *,theta1(23) C-DBG print *,'gflux in progtm' C-DBG call maxmin(gflux,im,1,im,1,1) C-DBG print *,gflux(23) C-DBG print *,'slwd in progtm' C-DBG call maxmin(slwd,im,1,im,1,1) C-DBG print *,slwd(23) C-DBG print *,'t1 in progtm' C-DBG call maxmin(t1,im,1,im,1,1) C-DBG print *,t1(23) C-DBG print *,'t12 in progtm' C-DBG call maxmin(t12,im,1,im,1,1) C-DBG print *,t12(23) C-DBG print *,'t14 in progtm' C-DBG call maxmin(t14,im,1,im,1,1) C-DBG print *,t14(23) C-DBG print *,'rch in progtm' C-DBG call maxmin(rch,im,1,im,1,1) C-DBG print *,rch(23) C-DBG print *,'qs1 in progtm' C-DBG call maxmin(qs1,im,1,im,1,1) C-DBG print *,qs1(23) C-DBG print *,'q0 in progtm' C-DBG call maxmin(q0,im,1,im,1,1) C-DBG print *,q0(23) C-DBG print *,'rsmall in progtm' C-DBG call maxmin(rsmall,im,1,im,1,1) C-DBG print *,rsmall(23) C-DBG print *,'rcap in progtm' C-DBG call maxmin(rcap,im,1,im,1,1) C-DBG print *,rcap(23) C-DBG print *,'delta in progtm' C-DBG call maxmin(delta,im,1,im,1,1) C-DBG print *,delta(23) C-DBG print *,'ep in progtm' C-DBG call maxmin(ep,im,1,im,1,1) C-DBG print *,ep(23) C C ACTUAL EVAPORATION OVER LAND IN THREE PARTS : EDIR, ET, AND EC C C DIRECT EVAPORATION FROM SOIL, THE UNIT GOES FROM M S-1 TO KG M-2 S-1 C DO I = 1, IM FLAG(I) = SLIMSK(I).EQ.1..AND.EP(I).GT.0. ENDDO DO I = 1, IM IF(FLAG(I)) THEN TREF(I) = .75 * THSAT(SOILTYP(I)) TWILT(I) = TWLT(SOILTYP(I)) DF1(I) = FUNCDF(SMC(I,1),SOILTYP(I)) KT1(I) = FUNCKT(SMC(I,1),SOILTYP(I)) FX(I) = -2. * DF1(I) * (SMC(I,1) - .23) / ZSOIL(I,1) & - KT1(I) FX(I) = FX(I) FX(I) = MIN(FX(I), EP(I)/HVAP) FX(I) = MAX(FX(I),0.) C C SIGMAF IS THE FRACTION OF AREA COVERED BY VEGETATION C EDIR(I) = FX(I) * (1. - SIGMAF(I)) * PARTLND(I) ENDIF ENDDO C C TRANSPIRATION FROM ALL LEVELS OF THE SOIL C DO I = 1, IM IF(FLAG(I)) THEN CANFAC(I) = (CANOPY(I) / SCANOP) ** CFACTR ETPFAC(I) = SIGMAF(I) * ETP(I) & * (1. - CANFAC(I)) / HVAP GX(I) = (SMC(I,1) - TWILT(I)) / (TREF(I) - TWILT(I)) GX(I) = MAX(GX(I),0.) GX(I) = MIN(GX(I),1.) ET(I,1) = (ZSOIL(I,1) / ZSOIL(I,KM)) * GX(I) * ETPFAC(I) & * PARTLND(I) ENDIF ENDDO DO K = 2, KM DO I = 1, IM IF(FLAG(I)) THEN GX(I) = (SMC(I,K) - TWILT(I)) / (TREF(I) - TWILT(I)) GX(I) = MAX(GX(I),0.) GX(I) = MIN(GX(I),1.) ET(I,K) = & (ZSOIL(I,K) - ZSOIL(I,K-1)) / ZSOIL(I,KM) & * GX(I) * ETPFAC(I) * PARTLND(I) ENDIF ENDDO ENDDO 400 CONTINUE C C CANOPY RE-EVAPORATION C DO I = 1, IM IF(FLAG(I)) THEN EC(I) = SIGMAF(I) * CANFAC(I) * EP(I) / HVAP EC(I) = EC(I) * PARTLND(I) C EC(I) = MIN(EC(I),CANOPY(I)/DELT2) ENDIF ENDDO C C SUM UP TOTAL EVAPORATION C DO I = 1, IM IF(FLAG(I)) THEN EVAP(I) = EDIR(I) + EC(I) ENDIF ENDDO DO K = 1, KM DO I = 1, IM IF(FLAG(I)) THEN EVAP(I) = EVAP(I) + ET(I,K) ENDIF ENDDO ENDDO C-DBG print *,'total evap in progtm' C-DBG call maxmin(evap,im,1,im,1,1) C-DBG print *,'edir in progtm' C-DBG call maxmin(edir,im,1,im,1,1) C-DBG print *,'et in progtm' C-DBG call maxmin(et,im,1,im,1,1) C-DBG print *,'ec in progtm' C-DBG call maxmin(ec,im,1,im,1,1) C-DBG print *,'flag',flag C C RETURN EVAP UNIT FROM KG M-2 S-1 TO WATTS M-2 C DO I = 1, IM IF(FLAG(I)) THEN EVAP(I) = MIN(EVAP(I)*HVAP,EP(I)) ENDIF ENDDO C-DBG print *,'total evap in progtm. unit conversion.' C-DBG call maxmin(evap,im,1,im,1,1) C-DBG print *,'hvap=',hvap C-DBG print *,'ep in progtm' C-DBG call maxmin(ep,im,1,im,1,1) C C IF(LAT.EQ.LATD) THEN C I = LOND C PRINT *, 'FX, SIGMAF, EDIR, ETPFAC=', FX(I)*HVAP,SIGMAF(I), C & EDIR(I)*HVAP,ETPFAC(I)*HVAP C PRINT *, ' ET =', (ET(I,K)*HVAP,K=1,KM) C PRINT *, ' CANFAC, EC, EVAP', CANFAC(I),EC(I)*HVAP,EVAP(I) C ENDIF C C EVAPORATION OVER BARE SEA ICE C DO I = 1, IM C IF(SLIMSK(I).EQ.2.AND.SNOWD(I).LE..001) THEN IF(SLIMSK(I).EQ.2.) THEN EVAP(I) = PARTLND(I) * EP(I) ENDIF ENDDO C-DBG print *,'EVAP over sea ice in PROGTM' C-DBG call maxmin(EVAP,im,1,im,1,1) C-DBG print *,'PARTLND PROGTM' C-DBG call maxmin(PARTLND,im,1,im,1,1) C-DBG print *,'EP PROGTM' C-DBG call maxmin(EP,im,1,im,1,1) C C TREAT DOWNWARD MOISTURE FLUX SITUATION C (EVAP WAS PRESET TO ZERO SO NO UPDATE NEEDED) C DEW IS CONVERTED FROM KG M-2 TO M TO CONFORM TO PRECIP UNIT C DO I = 1, IM FLAG(I) = SLIMSK(I).NE.0..AND.EP(I).LE.0. DEW(I) = 0. ENDDO DO I = 1, IM IF(FLAG(I)) THEN DEW(I) = -EP(I) * DELT2 / (HVAP * RHOH2O) EVAP(I) = EP(I) DM(I) = 1. ENDIF ENDDO C C SNOW COVERED LAND AND SEA ICE C DO I = 1, IM FLAG(I) = SLIMSK(I).NE.0..AND.SNOWD(I).GT.0. ENDDO C C CHANGE OF SNOW DEPTH DUE TO EVAPORATION OR SUBLIMATION C C CONVERT EVAP FROM KG M-2 S-1 TO M S-1 TO DETERMINE THE REDUCTION OF S C DO I = 1, IM IF(FLAG(I)) THEN BFACT = SNOWD(I) / (DELT2 * EP(I) / (HVAP * RHOH2O)) BFACT = MIN(BFACT,1.) C C THE EVAPORATION OF SNOW C IF(EP(I).LE.0.) BFACT = 1. IF(SNOWD(I).LE..001) THEN EVAP(I) = (SNOWD(I)/.001)*BFACT*EP(I) + EVAP(I) SNOWEV(I) = (SNOWD(I)/.001)*BFACT*EP(I) ELSE EVAP(I) = BFACT * EP(I) SNOWEV(I) = BFACT * EP(I) ENDIF TSURF(I) = T1(I) + & (RCAP(I) - GFLUX(I) - DFSNOW * (T1(I) - STSOIL(I,1)) & /(FACTSNW(I) * MAX(SNOWD(I),.001)) & + THETA1(I) - T1(I) & - BFACT * EP(I)) / (RSMALL(I) * RCH(I) & + DFSNOW / (FACTSNW(I)* MAX(SNOWD(I),.001))) SNOWD(I) = SNOWD(I) - EP(I) * DELT / (RHOH2O * HVAP) SNOWD(I) = MAX(SNOWD(I),0.) ENDIF ENDDO C C SNOW MELT RATE (M S-1) C 500 CONTINUE DO I = 1, IM FLAG(I) = SLIMSK(I).NE.0. & .AND.SNOWD(I).GT..0 ENDDO DO I = 1, IM IF(FLAG(I).AND.TSURF(I).GT.T0C) THEN SNOWMT(I) = RCH(I) * RSMALL(I) & * (TSURF(I) - T0C) / (RHOH2O * HFUS) SNOWD(I) = SNOWD(I) - SNOWMT(I) * DELT SNOWD(I) = MAX(SNOWD(I),0.) SNOWMT(I) = MIN(SNOWMT(I),SNOWD(I) / DELT) TSURF(I) = MAX(T0C,TSURF(I) & -HFUS*SNOWMT(I)*RHOH2O/(RCH(I)*RSMALL(I))) C C WE NEED TO RE-EVALUATE EVAPORATION BECAUSE OF SNOW MELT C THE SKIN TEMPERATURE IS NOW BOUNDED TO 0 DEG C C QSS(I) = 1000. * FPVS(TSURF(I)) QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) EVAP(I) = ELOCP * RCH(I) * (QSS(I) - Q0(I)) ENDIF ENDDO C C PREPARE TENDENCY TERMS FOR THE SOIL MOISTURE FIELD WITHOUT PRECIPITAT C THE UNIT OF MOISTURE FLUX NEEDS TO BECOME M S-1 FOR SOIL MOISTURE C HENCE THE FACTOR OF RHOH2O C DO I = 1, IM FLAG(I) = SLIMSK(I).EQ.1. ENDDO DO I = 1, IM IF(FLAG(I)) THEN RHSCNPY(I) = -EC(I) + SIGMAF(I) * RHOH2O * DEW(I) / DELT2 SMCZ(I) = MAX(SMC(I,1), SMC(I,2)) DMDZ(I) = (SMC(I,1) - SMC(I,2)) / (-.5 * ZSOIL(I,2)) DF1(I) = FUNCDF(SMCZ(I),SOILTYP(I)) KT1(I) = FUNCKT(SMCZ(I),SOILTYP(I)) RHSMC(I,1) = (DF1(I) * DMDZ(I) + KT1(I) & + (EDIR(I) + ET(I,1))) / (ZSOIL(I,1) * RHOH2O) DDZ(I) = 1. / (-.5 * ZSOIL(I,2)) C C AIM, BIM, AND CIM ARE THE ELEMENTS OF THE TRIDIAGONAL MATRIX FOR THE C IMPLICIT UPDATE OF THE SOIL MOISTURE C AIM(I,1) = 0. BIM(I,1) = DF1(I) * DDZ(I) / (-ZSOIL(I,1) * RHOH2O) CIM(I,1) = -BIM(I,1) ENDIF ENDDO DO K = 2, KM IF(K.LT.KM) THEN DO I = 1, IM IF(FLAG(I)) THEN DMDZ2(I) = (SMC(I,K) - SMC(I,K+1)) & / (.5 * (ZSOIL(I,K-1) - ZSOIL(I,K+1))) SMCZ(I) = MAX(SMC(I,K), SMC(I,K+1)) DF2(I) = FUNCDF(SMCZ(I),SOILTYP(I)) KT2(I) = FUNCKT(SMCZ(I),SOILTYP(I)) RHSMC(I,K) = (DF2(I) * DMDZ2(I) + KT2(I) & - DF1(I) * DMDZ(I) - KT1(I) + ET(I,K)) & / (RHOH2O*(ZSOIL(I,K) - ZSOIL(I,K-1))) DDZ2(I) = 2. / (ZSOIL(I,K-1) - ZSOIL(I,K+1)) CIM(I,K) = -DF2(I) * DDZ2(I) & / ((ZSOIL(I,K-1) - ZSOIL(I,K))*RHOH2O) ENDIF ENDDO ELSE DO I = 1, IM IF(FLAG(I)) THEN KT2(I) = FUNCKT(SMC(I,K),SOILTYP(I)) RHSMC(I,K) = (KT2(I) & - DF1(I) * DMDZ(I) - KT1(I) + ET(I,K)) & / (RHOH2O*(ZSOIL(I,K) - ZSOIL(I,K-1))) DRAIN(I) = KT2(I) CIM(I,K) = 0. ENDIF ENDDO ENDIF DO I = 1, IM IF(FLAG(I)) THEN AIM(I,K) = -DF1(I) * DDZ(I) & / ((ZSOIL(I,K-1) - ZSOIL(I,K))*RHOH2O) BIM(I,K) = -(AIM(I,K) + CIM(I,K)) DF1(I) = DF2(I) KT1(I) = KT2(I) DMDZ(I) = DMDZ2(I) DDZ(I) = DDZ2(I) ENDIF ENDDO ENDDO 600 CONTINUE C C UPDATE SOIL TEMPERATURE AND SEA ICE TEMPERATURE C DO I = 1, IM FLAG(I) = SLIMSK(I).NE.0. ENDDO C C SURFACE TEMPERATURE IS PART OF THE UPDATE WHEN SNOW IS ABSENT C DO I = 1, IM C IF(FLAG(I).AND.SNOWD(I).LE..001) THEN IF(FLAG(I).AND..NOT.FLAGSNW(I)) THEN YY(I) = T1(I) + & (RCAP(I)-GFLUX(I) + THETA1(I) - T1(I) & - EVAP(I)) / (RSMALL(I) * RCH(I)) ZZ(I) = 1. + DFT0(I) / (-.5 * ZSOIL(I,1) * RCH(I) * RSMALL(I)) XX(I) = DFT0(I) * (STSOIL(I,1) - YY(I)) / & (.5 * ZSOIL(I,1) * ZZ(I)) ENDIF C IF(FLAG(I).AND.SNOWD(I).GT..001) THEN IF(FLAG(I).AND.FLAGSNW(I)) THEN YY(I) = STSOIL(I,1) C C HEAT FLUX FROM SNOW IS EXPLICIT IN TIME C ZZ(I) = 1. XX(I) = DFSNOW * (STSOIL(I,1) - TSURF(I)) & / (-FACTSNW(I) * MAX(SNOWD(I),.001)) ENDIF ENDDO C C COMPUTE THE FORCING AND THE IMPLICIT MATRIX ELEMENTS FOR UPDATE C C CH2O IS THE HEAT CAPACITY OF WATER AND CSOIL IS THE HEAT CAPACITY OF C DO I = 1, IM IF(FLAG(I)) THEN SMCZ(I) = MAX(SMC(I,1), SMC(I,2)) DTDZ1(I) = (STSOIL(I,1) - STSOIL(I,2)) / (-.5 * ZSOIL(I,2)) IF(SLIMSK(I).EQ.1.) THEN DFT1(I) = KTSOIL(SMCZ(I),SOILTYP(I)) HCPCT(I) = SMC(I,1) * CH2O + (1. - SMC(I,1)) * CSOIL ELSE DFT1(I) = DFT0(I) HCPCT(I) = CICE ENDIF DFT2(I) = DFT1(I) DDZ(I) = 1. / (-.5 * ZSOIL(I,2)) C C AI, BI, AND CI ARE THE ELEMENTS OF THE TRIDIAGONAL MATRIX FOR THE C IMPLICIT UPDATE OF THE SOIL TEMPERATURE C AI(I,1) = 0. BI(I,1) = DFT1(I) * DDZ(I) / (-ZSOIL(I,1) * HCPCT(I)) CI(I,1) = -BI(I,1) BI(I,1) = BI(I,1) & + DFT0(I) / (.5 * ZSOIL(I,1) **2 * HCPCT(I) * ZZ(I)) C SS = DFT0(I) * (STSOIL(I,1) - YY(I)) C & / (.5 * ZSOIL(I,1) * ZZ(I)) C RHSTC(I,1) = (DFT1(I) * DTDZ1(I) - SS) RHSTC(I,1) = (DFT1(I) * DTDZ1(I) - XX(I)) & / (ZSOIL(I,1) * HCPCT(I)) ENDIF ENDDO DO K = 2, KM DO I = 1, IM IF(SLIMSK(I).EQ.1.) THEN HCPCT(I) = SMC(I,K) * CH2O + (1. - SMC(I,K)) * CSOIL ELSEIF(SLIMSK(I).EQ.2.) THEN HCPCT(I) = CICE ENDIF ENDDO IF(K.LT.KM) THEN DO I = 1, IM IF(FLAG(I)) THEN DTDZ2(I) = (STSOIL(I,K) - STSOIL(I,K+1)) & / (.5 * (ZSOIL(I,K-1) - ZSOIL(I,K+1))) SMCZ(I) = MAX(SMC(I,K), SMC(I,K+1)) IF(SLIMSK(I).EQ.1.) THEN DFT2(I) = KTSOIL(SMCZ(I),SOILTYP(I)) ENDIF DDZ2(I) = 2. / (ZSOIL(I,K-1) - ZSOIL(I,K+1)) CI(I,K) = -DFT2(I) * DDZ2(I) & / ((ZSOIL(I,K-1) - ZSOIL(I,K)) * HCPCT(I)) ENDIF ENDDO ELSE C C AT THE BOTTOM, CLIMATOLOGY IS ASSUMED AT 2M DEPTH FOR LAND AND C FREEZING TEMPERATURE IS ASSUMED FOR SEA ICE AT Z(I,KM) DO I = 1, IM IF(SLIMSK(I).EQ.1.) THEN DTDZ2(I) = (STSOIL(I,K) - TG3(I)) & / (.5 * (ZSOIL(I,K-1) + ZSOIL(I,K)) - ZBOT) DFT2(I) = KTSOIL(SMC(I,K),SOILTYP(I)) CI(I,K) = 0. ENDIF IF(SLIMSK(I).EQ.2.) THEN DTDZ2(I) = (STSOIL(I,K) - TGICE) & / (.5 * ZSOIL(I,K-1) - .5 * ZSOIL(I,K)) DFT2(I) = DFT1(I) CI(I,K) = 0. ENDIF ENDDO ENDIF DO I = 1, IM IF(FLAG(I)) THEN RHSTC(I,K) = (DFT2(I) * DTDZ2(I) - DFT1(I) * DTDZ1(I)) & / ((ZSOIL(I,K) - ZSOIL(I,K-1)) * HCPCT(I)) AI(I,K) = -DFT1(I) * DDZ(I) & / ((ZSOIL(I,K-1) - ZSOIL(I,K)) * HCPCT(I)) BI(I,K) = -(AI(I,K) + CI(I,K)) DFT1(I) = DFT2(I) DTDZ1(I) = DTDZ2(I) DDZ(I) = DDZ2(I) ENDIF ENDDO ENDDO 700 CONTINUE C C SOLVE THE TRI-DIAGONAL MATRIX C DO K = 1, KM DO I = 1, IM IF(FLAG(I)) THEN RHSTC(I,K) = RHSTC(I,K) * DELT2 AI(I,K) = AI(I,K) * DELT2 BI(I,K) = 1. + BI(I,K) * DELT2 CI(I,K) = CI(I,K) * DELT2 ENDIF ENDDO ENDDO C FORWARD ELIMINATION DO I = 1, IM IF(FLAG(I)) THEN CI(I,1) = -CI(I,1) / BI(I,1) RHSTC(I,1) = RHSTC(I,1) / BI(I,1) ENDIF ENDDO DO K = 2, KM DO I = 1, IM IF(FLAG(I)) THEN CC = 1. / (BI(I,K) + AI(I,K) * CI(I,K-1)) CI(I,K) = -CI(I,K) * CC RHSTC(I,K) = (RHSTC(I,K) - AI(I,K) * RHSTC(I,K-1)) * CC ENDIF ENDDO ENDDO C BACKWARD SUBSTITUTTION DO I = 1, IM IF(FLAG(I)) THEN CI(I,KM) = RHSTC(I,KM) ENDIF ENDDO DO K = KM-1, 1 DO I = 1, IM IF(FLAG(I)) THEN CI(I,K) = CI(I,K) * CI(I,K+1) + RHSTC(I,K) ENDIF ENDDO ENDDO C C UPDATE SOIL AND ICE TEMPERATURE C DO K = 1, KM DO I = 1, IM IF(FLAG(I)) THEN STSOIL(I,K) = STSOIL(I,K) + CI(I,K) ENDIF ENDDO ENDDO C C UPDATE SURFACE TEMPERATURE FOR SNOW FREE SURFACES C DO I = 1, IM C IF(SLIMSK(I).NE.0..AND.SNOWD(I).LE..001) THEN IF(SLIMSK(I).NE.0..AND..NOT.FLAGSNW(I)) THEN TSURF(I) = (YY(I) + (ZZ(I) - 1.) * STSOIL(I,1)) / ZZ(I) ENDIF C IF(SLIMSK(I).EQ.2..AND.SNOWD(I).LE..001) THEN IF(SLIMSK(I).EQ.2..AND..NOT.FLAGSNW(I)) THEN TSURF(I) = MIN(TSURF(I),T0C) ENDIF ENDDO DO K = 1, KM DO I = 1, IM IF(SLIMSK(I).EQ.2) THEN STC(I,K) = MIN(STSOIL(I,K),T0C) ENDIF ENDDO ENDDO C C TIME FILTER FOR SOIL AND SKIN TEMPERATURE C C-DBG print *,'TSURF in PROGTM' C-DBG call maxmin(TSURF,IM,1,IM,1,1) IF(INISTP.EQ.0) THEN DO I = 1, IM IF(SLIMSK(I).NE.0.) THEN TSKIN(I) = CTFIL1 * TSURF(I) + CTFIL2 * TSKIN(I) ENDIF ENDDO C-DBG print *,'TSKIN in PROGTM' C-DBG call maxmin(TSKIN,IM,1,IM,1,1) DO K = 1, KM DO I = 1, IM IF(SLIMSK(I).NE.0.) THEN STC(I,K) = CTFIL1 * STSOIL(I,K) + CTFIL2 * STC(I,K) ENDIF ENDDO ENDDO ENDIF C C GFLUX CALCULATION C DO I = 1, IM FLAG(I) = SLIMSK(I).NE.0. C & .AND.SNOWD(I).GT..001 & .AND.FLAGSNW(I) ENDDO DO I = 1, IM IF(FLAG(I)) THEN GFLUX(I) = -DFSNOW * (TSKIN(I) - STC(I,1)) & / (FACTSNW(I) * MAX(SNOWD(I),.001)) ENDIF ENDDO DO I = 1, IM C IF(SLIMSK(I).NE.0..AND.SNOWD(I).LE..001) THEN IF(SLIMSK(I).NE.0..AND..NOT.FLAGSNW(I)) THEN GFLUX(I) = DFT0(I) * (STC(I,1) - TSKIN(I)) & / (-.5 * ZSOIL(I,1)) ENDIF ENDDO C C CALCULATE SENSIBLE HEAT FLUX C DO I = 1, IM HFLX(I) = RCH(I) * (TSKIN(I) - THETA1(I)) ENDDO C C THE REST OF THE OUTPUT C DO I = 1, IM QSURF(I) = Q0(I) + EVAP(I) / (ELOCP * RCH(I)) DM(I) = 1. C C CONVERT SNOW DEPTH BACK TO MM OF WATER EQUIVALENT C SHELEG(I) = SNOWD(I) * 1000. ENDDO C-DBG print *,'ELOCP=',ELOCP C-DBG print *,'QSURF in PROGTM' C-DBG call maxmin(QSURF,im,1,im,1,1) C-DBG print *,'EVAP in PROGTM' C-DBG call maxmin(EVAP,im,1,im,1,1) C-DBG print *,'RCH in PROGTM' C-DBG call maxmin(RCH,im,1,im,1,1) C IF(INISTP.EQ.3) THEN DO I = 1, IM F10M(I) = FM10(I) / FM(I) U10M(I) = F10M(I) * XRCL * U1(I) V10M(I) = F10M(I) * XRCL * V1(I) T2M(I) = TSKIN(I) * (1. - FH2(I) / FH(I)) & + THETA1(I) * FH2(I) / FH(I) T2M(I) = T2M(I) * SIG2K C Q2M(I) = QSURF(I) * (1. - FH2(I) / FH(I)) C & + Q0(I) * FH2(I) / FH(I) C T2M(I) = T1(I) C Q2M(I) = Q0(I) IF(EVAP(I).GE.0.) THEN C C IN CASE OF EVAPORATION, USE THE INFERRED QSURF TO DEDUCE Q2M C Q2M(I) = QSURF(I) * (1. - FH2(I) / FH(I)) & + Q0(I) * FH2(I) / FH(I) ELSE C C FOR DEW FORMATION SITUATION, USE SATURATED Q AT TSKIN C QSS(I) = 1000. * FPVS(TSKIN(I)) QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) Q2M(I) = QSS(I) * (1. - FH2(I) / FH(I)) & + Q0(I) * FH2(I) / FH(I) ENDIF QSS(I) = 1000. * FPVS(T2M(I)) QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) Q2M(I) = MIN(Q2M(I),QSS(I)) ENDDO C ENDIF 800 CONTINUE DO I = 1, IM RNET(I) = -SLWD(I) - SIGMA * TSKIN(I) **4 ENDDO C IF(LAT.EQ.LATD) THEN C I = LOND CC RBAL = -SLWD(I)-SIGMA*TSKIN(I)**4+GFLUX(I) CC & -EVAP(I) - HFLX(I) C PRINT *, ' HFLX,EVAP,GFLUX,STC,TS,RNET,SLWD' C PRINT 6000,HFLX(I),EVAP(I),GFLUX(I), C & STC(I,1), STC(I,2),TSKIN(I),RNET(I),SLWD(I) C PRINT *, ' T1 =', T1(I) C 6000 FORMAT(8(F8.2,',')) CC PRINT *, ' EP, ETP,T2M =', EP(I), ETP(I),T2M(I) CC PRINT *, ' FH, FH2 =', FH(I), FH2(I) CC PRINT *, ' PH, PH2 =', PH(I), PH2(I) CC PRINT *, ' CH, RCH =', CH(I), RCH(I) CC PRINT *, ' TERM1, TERM2 =', TERM1(I), TERM2(I) CC PRINT *, ' RS, PLANTR =', RS(I), PLANTR(I) C ENDIF RETURN END C C PROGT2 IS THE SECOND PART OF THE SOIL MODEL THAT IS EXECUTED C AFTER PRECIPITATION FOR THE TIME STEP HAS BEEN CALCULATED C CFPP$ NOCONCUR R CFPP$ EXPAND(FUNCDF,FUNCKT,THSAT) SUBROUTINE PROGT2(IMX2,KMX,RHSCNPY,RHSMC,AI,BI,CI,SMC,SLIMSK, & CANOPY,PRECIP,RUNOFF,SNOWMT, & ZSOIL,SOILTYP,SIGMAF,DELT,LAT) PARAMETER (SCANOP=2.,RHOH2O=1000.) PARAMETER (CTFIL1=.5,CTFIL2=1.-CTFIL1) PARAMETER (RFFACT=.15) DIMENSION RHSCNPY(IMX2),RHSMC(IMX2,KMX) DIMENSION AI(IMX2,KMX),BI(IMX2,KMX),CI(IMX2,KMX) DIMENSION SMC(IMX2,KMX),CANOPY(IMX2),PRECIP(IMX2),SOILTYP(IMX2) DIMENSION SIGMAF(IMX2),SLIMSK(IMX2),RUNOFF(IMX2) DIMENSION ZSOIL(IMX2,KMX),SNOWMT(IMX2) INTEGER SOILTYP REAL INF, INFMAX, KSAT C LOCAL ARRAY LOGICAL FLAG( 384 ) DIMENSION PRCP( 384 ),INF( 384 ),INFMAX( 384 ) DIMENSION TSAT( 384 ),DSAT( 384 ),KSAT( 384 ) DIMENSION SMSOIL( 384 , 28 ),CNPY( 384 ),DEW( 384 ) IM = IMX2 KM = KMX LATD = 44 LOND = 353 DELT2 = DELT * 2. C C PRECIPITATION RATE IS NEEDED IN UNIT OF KG M-2 S-1 C DO I = 1, IM PRCP(I) = RHOH2O * (PRECIP(I)/DELT+SNOWMT(I)) RUNOFF(I) = 0. CNPY(I) = CANOPY(I) ENDDO C IF(LAT.EQ.LATD) THEN C I = LOND C PRINT *, ' BEFORE RUNOFF CAL, RHSMC =', RHSMC(I,1) C ENDIF C C UPDATE CANOPY WATER CONTENT C DO I = 1, IM IF(SLIMSK(I).EQ.1.) THEN RHSCNPY(I) = RHSCNPY(I) + SIGMAF(I) * PRCP(I) CANOPY(I) = CANOPY(I) + DELT2 * RHSCNPY(I) CANOPY(I) = MAX(CANOPY(I),0.) PRCP(I) = PRCP(I) * (1. - SIGMAF(I)) IF(CANOPY(I).GT.SCANOP) THEN DRIP = CANOPY(I) - SCANOP CANOPY(I) = SCANOP PRCP(I) = PRCP(I) + DRIP / DELT2 ENDIF C C CALCULATE INFILTRATION RATE C INF(I) = PRCP(I) TSAT(I) = THSAT(SOILTYP(I)) C DSAT(I) = FUNCDF(TSAT(I),SOILTYP(I)) C KSAT(I) = FUNCKT(TSAT(I),SOILTYP(I)) C INFMAX(I) = -DSAT(I) * (TSAT(I) - SMC(I,1)) C & / (.5 * ZSOIL(I,1)) C & + KSAT(I) INFMAX(I) = (-ZSOIL(I,1)) * & ((TSAT(I) - SMC(I,1)) / DELT2 - RHSMC(I,1)) & * RHOH2O INFMAX(I) = MAX(RFFACT*INFMAX(I),0.) C IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = KSAT(I) C IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = ZSOIL(I,1) * RHSMC(I,1) IF(INF(I).GT.INFMAX(I)) THEN RUNOFF(I) = INF(I) - INFMAX(I) INF(I) = INFMAX(I) ENDIF INF(I) = INF(I) / RHOH2O RHSMC(I,1) = RHSMC(I,1) - INF(I) / ZSOIL(I,1) ENDIF ENDDO C IF(LAT.EQ.LATD) THEN C I = LOND C PRINT *, ' PRCP, INFMAX, RUNOFF =', PRCP(I),INFMAX(I),RUNOFF(I) C PRINT *, ' SMSOIL =', SMC(I,1), SMC(I,2) C PRINT *, ' RHSMC =', RHSMC(I,1) C ENDIF C C WE CURRENTLY IGNORE THE EFFECT OF RAIN ON SEA ICE C DO I = 1, IM FLAG(I) = SLIMSK(I).EQ.1. ENDDO C C SOLVE THE TRI-DIAGONAL MATRIX C DO K = 1, KM DO I = 1, IM IF(FLAG(I)) THEN RHSMC(I,K) = RHSMC(I,K) * DELT2 AI(I,K) = AI(I,K) * DELT2 BI(I,K) = 1. + BI(I,K) * DELT2 CI(I,K) = CI(I,K) * DELT2 ENDIF ENDDO ENDDO C FORWARD ELIMINATION DO I = 1, IM IF(FLAG(I)) THEN CI(I,1) = -CI(I,1) / BI(I,1) RHSMC(I,1) = RHSMC(I,1) / BI(I,1) ENDIF ENDDO DO K = 2, KM DO I = 1, IM IF(FLAG(I)) THEN CC = 1. / (BI(I,K) + AI(I,K) * CI(I,K-1)) CI(I,K) = -CI(I,K) * CC RHSMC(I,K) = (RHSMC(I,K) - AI(I,K) * RHSMC(I,K-1)) * CC ENDIF ENDDO ENDDO C BACKWARD SUBSTITUTTION DO I = 1, IM IF(FLAG(I)) THEN CI(I,KM) = RHSMC(I,KM) ENDIF ENDDO DO K = KM-1, 1 DO I = 1, IM IF(FLAG(I)) THEN CI(I,K) = CI(I,K) * CI(I,K+1) + RHSMC(I,K) ENDIF ENDDO ENDDO 100 CONTINUE C C UPDATE SOIL MOISTURE C DO K = 1, KM DO I = 1, IM IF(FLAG(I)) THEN SMSOIL(I,K) = SMC(I,K) + CI(I,K) SMSOIL(I,K) = MAX(SMSOIL(I,K),0.) TDIF = MAX(SMSOIL(I,K) - TSAT(I),0.) RUNOFF(I) = RUNOFF(I) - & RHOH2O * TDIF * ZSOIL(I,K) / DELT2 SMSOIL(I,K) = SMSOIL(I,K) - TDIF ENDIF ENDDO ENDDO DO K = 1, KM DO I = 1, IM IF(FLAG(I)) THEN SMC(I,K) = CTFIL1 * SMSOIL(I,K) + CTFIL2 * SMC(I,K) ENDIF ENDDO ENDDO DO I = 1, IM IF(FLAG(I)) THEN CANOPY(I) = CTFIL1 * CANOPY(I) + CTFIL2 * CNPY(I) ENDIF ENDDO C I = 1 C PRINT *, ' SMC' C PRINT 6000, SMC(I,1), SMC(I,2) 6000 FORMAT(2(F8.5,',')) RETURN END C C GRDDF SETS UP MOISTURE DIFFUSIVITY AND HYDROLIC CONDUCTIVITY C FOR ALL SOIL TYPES C GRDDFS SETS UP THERMAL DIFFUSIVITY FOR ALL SOIL TYPES C BLOCK DATA DFKT PARAMETER (NTYPE=11) COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) DATA B/4.05,4.38,4.9,5.3,5.39,7.12,7.75,8.52, & 10.4,10.4,11.4/ DATA SATPSI/.121,.09,.218,.786,.478,.299,.356,.63, & .153,.49,.405/ DATA SATKT/1.76E-4,1.5633E-4,3.467E-5,7.2E-6,6.95E-6, & 6.3E-6,1.7E-6,2.45E-6,2.167E-6,1.033E-6, & 1.283E-6/ DATA TSAT/.395,.41,.435,.485,.451,.42,.477,.476, & .426,.492,.482/ END SUBROUTINE GRDDF PARAMETER(NTYPE=11,NGRID=22) COMMON /COMGDF/ DFK(NGRID,NTYPE) COMMON /COMGKT/ KTK(NGRID,NTYPE) REAL KTK COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) DO K = 1, NTYPE DYNW = TSAT(K) * .05 F1 = B(K) * SATKT(K) * SATPSI(K) / TSAT(K) ** (B(K) + 3.) F2 = SATKT(K) / TSAT(K) ** (B(K) * 2. + 3.) C C CONVERT FROM M/S TO KG M-2 S-1 UNIT C F1 = F1 * 1000. F2 = F2 * 1000. DO I = 1, NGRID THETA = FLOAT(I-1) * DYNW THETA = MIN(TSAT(K),THETA) DFK(I,K) = F1 * THETA ** (B(K) + 2.) KTK(I,K) = F2 * THETA ** (B(K) * 2. + 3.) ENDDO ENDDO RETURN END SUBROUTINE GRDKT PARAMETER(NTYPE=11,NGRID=22) COMMON /COMGDFT/ DFKT(NGRID,NTYPE) COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) DO K = 1, NTYPE DYNW = TSAT(K) * .05 F1 = LOG10(SATPSI(K)) + B(K) * LOG10(TSAT(K)) + 2. DO I = 1, NGRID THETA = FLOAT(I-1) * DYNW THETA = MIN(TSAT(K),THETA) IF(THETA.GT.0.) THEN PF = F1 - B(K) * LOG10(THETA) ELSE PF = 5.2 ENDIF IF(PF.LE.5.1) THEN DFKT(I,K) = EXP(-(2.7+PF)) * 420. ELSE DFKT(I,K) = .1744 ENDIF ENDDO ENDDO RETURN END REAL FUNCTION KTSOIL(THETA,KTYPE) PARAMETER(NTYPE=11,NGRID=22) COMMON /COMGDFT/ DFKT(NGRID,NTYPE) COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) W = (THETA / TSAT(KTYPE)) * 20. + 1. KW = W KW = MIN(KW,21) KW = MAX(KW,1) KTSOIL = DFKT(KW,KTYPE) & + (W - KW) * (DFKT(KW+1,KTYPE) - DFKT(KW,KTYPE)) RETURN END FUNCTION FUNCDF(THETA,KTYPE) PARAMETER(NTYPE=11,NGRID=22) COMMON /COMGDF/ DFK(NGRID,NTYPE) COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) W = (THETA / TSAT(KTYPE)) * 20. + 1. KW = W KW = MIN(KW,21) KW = MAX(KW,1) FUNCDF = DFK(KW,KTYPE) & + (W - KW) * (DFK(KW+1,KTYPE) - DFK(KW,KTYPE)) RETURN END FUNCTION FUNCKT(THETA,KTYPE) PARAMETER(NTYPE=11,NGRID=22) COMMON /COMGKT/ KTK(NGRID,NTYPE) REAL KTK COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) W = (THETA / TSAT(KTYPE)) * 20. + 1. KW = W KW = MIN(KW,21) KW = MAX(KW,1) FUNCKT = KTK(KW,KTYPE) & + (W - KW) * (KTK(KW+1,KTYPE) - KTK(KW,KTYPE)) RETURN END FUNCTION THSAT(KTYPE) PARAMETER(NTYPE=11,NGRID=22) COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) THSAT = TSAT(KTYPE) RETURN END FUNCTION TWLT(KTYPE) PARAMETER(NTYPE=11,NGRID=22) COMMON /COMGDFKT/ B(NTYPE),SATPSI(NTYPE),SATKT(NTYPE),TSAT(NTYPE) TWLT = .1 RETURN END SUBROUTINE RDLWSW(IX,IX2,QS,SIGI,SIGL, 1 LAT,XLAT,SOLC,RSIN1,RCOS1,RCOS2,SLMSK, 2 QQH2O,TT,O3QO3,TSFC,COSZRO,CLDARY, 3 ALBEDO,ALBVB,ALBNB,ALBVD,ALBND,PAERS, 4 ITIMSW,ITIMLW,KO3,KALB,ISWSRC, 5 HTLW,SLWUP,SLWDN,TLWUP, 6 HTSW,SSWUP,SSWDN,TSWUP,TSWDN, 6 TLWUP0,TSWUP0,SSWDN0,SSWUP0,SLWDN0, 7 SSWFVB,SSWFNB,SSWFVD,SSWFND) C 7 ITM,SSWFVB,SSWFNB,SSWFVD,SSWFND) CFPP$ NOCONCUR R C INCLUDE DBRDLWSW ; C ******************************************************************** C * REWRITE THE GFDL CODE "RADFS" TO CALL M.D.CHOU'S SW RADIATION C * AND TO CALL THE GFDL LW RADIATION Y-T HOU DEC1994 C * C * ARGUMENT LIST: C * INPUT C * IX,IX2 - FIRST DIMENSIONS OF ARRAYS C * QS - SURFACE PRESSURE IN CB C * SIGI - MODEL SIGMA INTERFACE LEVEL (K=1 AT THE SFC) C * SIGL - MODEL SIGMA LAYER MEAN VALUE C * LAT,XLAT - LAT INDEX AND RADIANS C * SOLC - SOLAR CONSTANT IN LY/MIN C * RSIN1,RCOS1,RCOS2 C * - SIN AND COS LAT FOR OZONE INTERPOLATIONS C * SLMSK - LAND/SEA/ICE MASK (0:SEA.1:LAND,2:ICE) C * QQH2O - SEPCIFIC HUMIDITY IN G/G (K=1 AT THE SFC) C * TT - TEMPERATURE IN K (K=1 AT THE SFC) C * O3QO3 - OZONE CONCENTRATION IN G/G (K=1 AT THE SFC) C * TSFC - SURFACE TEMPERATURE IN K C * COSZRO - COSINE OF ZENITH ANGLE C * CLDARY - PACKED CLOUD ARRAY (K=1 AT THE SFC) C * ALBEDO - SURFACE ALBEDO FROM CLIMOTOLOGY C * ALBVB,ALBVD - VIS BAND ALBEDOES FOR BEAM AND DIFF RADIATION C * ALBNB,ALBND - NIR BAND ALBEDOES FOR BEAM AND DIFF RADIATION C * PAERS - AEROSOL PROFILES (IN FRACTIONS) C * CONTROL FLAGS C * ITIMSW,ITIMLW C * - SW, LW RADIATION CALLS DURATION IN HOUR C * KO3 - OZONE DATA, =1 INPUT DATA; =0 GFDL CLIMOTOLOGY C * KALB - SFC ALB, =0 CLIMOTOLOGY, COMP OVER OCEANS C * =1 INPUT FOUR COMPONENTS FROM CALLING PROGM C * ISWSRC - FLAGS FOR SELECTION OF SW ABSORBERS C * 1:AEROSOLS, 2:O2, 3:CO2, 4:H2O, 5:O3 C * =0:WITHOUT; =1 WITH C * OUTPUT C * HTLW - LW HEATING RATES IN K/SEC C * SLWUP - SFC UPWARD LW FLUX IN W/M**2 C * SLWDN - SFC DOWNWARD LW FLUX IN W/M**2 C * TLWUP - TOA UPWARD LW FLUX IN W/M**2 C * HTSW - SW HEATING RATES IN K/SEC C * SSWUP - SFC UPWARD SW FLUX IN W/M**2 C * SSWDN - SFC DOWNWARD SW FLUX IN W/M**2 C * TSWUP - TOA UPWARD SW FLUX IN W/M**2 C * TSWDN - TOA DOWNWARD SW IN W/M**2 C * TLWUP0 - CLEAR SKY TOA UPWARD LW FLUX C TSWUP0 - CLEAR SKY TOA UPWARD SW FLUX C * SSWDN0 - CLEAR SKY SFC DOWNWARD SW FLUX C * SSWUP0 - CLEAR SKY SFC UPWARD SW FLUX C * SLWDN0 - CLEAR SKY SFC DOWNWARD LW FLUX C * SSWFVB - VIS BEAM DOWN SW FLUX AT SFC IN W/M**2 C * SSWFVD - VIS DIFF DOWN SW FLUX AT SFC IN W/M**2 C * SSWFNB - NIR BEAM DOWN SW FLUX AT SFC IN W/M**2 C * SSWFND - NIR DIFF DOWN SW FLUX AT SFC IN W/M**2 C ******************************************************************** C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) PARAMETER (LNGTH=37*L, NRCHNK=( 384 -1)/IMAX+1) C --- INPUT FROM FROM CALLING PROGRAM D I M E N S I O N 1 QS (IX2), SIGI (LP1), SIGL (L), SLMSK(IX) 2, QQH2O(IX2,L),TT (IX2,L),TSFC (IX), O3QO3(IX,L) 3, CLDARY(IX,L),COSZRO(IX), ALBEDO(IX), XLAT(IX) 4, ALBVB(IX), ALBNB(IX), ALBVD(IX), ALBND(IX) 5, PAERS(IX,NAE-1), ISWSRC(NSRC) C --- OUTPUT TO CALLING PROGRAM D I M E N S I O N 1 HTLW (IX,L), SLWUP(IX), SLWDN(IX), TLWUP(IX) 2, HTSW (IX,L), SSWUP(IX), SSWDN(IX), TSWUP(IX), TSWDN(IX) C --- FOUR COMPONENTS OF DOWNWARD SW FLUX 3, SSWFVB(IX), SSWFNB(IX), SSWFVD(IX), SSWFND(IX) 4, TLWUP0(IX), TSWUP0(IX), SSWDN0(IX), SSWUP0(IX), SLWDN0(IX) C --- INTERNAL ARRAYS D I M E N S I O N C --- LOCAL ARRAYS FOR RADIATIVE QUANTITIES 1 HLW(IMBX,L), TLWUC(IMAX), SLWNC(IMAX), TSWDC(IMAX) 2, HSW(IMBX,L), TSWUC(IMAX), SSWUC(IMAX), SSWDC(IMAX) 3, TLWU0(IMAX), TSWU0(IMAX), SSWD0(IMAX), SSWU0(IMAX), SLWN0(IMAX) C --- LOCAL ARRAYS FOR CLOUDS D I M E N S I O N 1 NCLDS(IMAX), CFACSW(IMBX,LP1), CFACLW(IMBX,LP1,LP1) 2, KTOP (IMBX,LP1), KBTM (IMBX,LP1) 3, CLDLW(IMBX,LP1), CLDSW (IMBX,L), TAUCL (IMBX,L) C --- LOCAL ARRAYS FOR OTHERS D I M E N S I O N 1 PRSSI(IMBX,LP1), PRSSL(IMBX,LP1), TEMP (IMBX,LP1),SFCALB(IMAX) 2, PAERA(IMBX,NAE), RH2O (IMBX,L), QO3 (IMBX,L), COSZEN(IMAX) 3, ALVB (IMAX), ALNB (IMAX), ALVD (IMAX), ALND (IMAX) 4, GDFVB(IMAX), GDFNB(IMAX), GDFVD(IMAX), GDFND(IMAX) 5, JJROW(IMAX), DO3V (IMAX), DO3VP(IMAX), TTHAN(IMAX) C --- SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN C CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE). C DEFINED AS 5 DEG LAT MEANS N.P.->S.P. C O M M O N /SAVMEM/ C --- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... 1 DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L) D I M E N S I O N 1 RAD1(LNGTH), RAD2(LNGTH), RAD3(LNGTH), RAD4(LNGTH) EQUIVALENCE (RAD1(1),DDUO3N(1,1)),(RAD2(1),DDO3N2(1,1)) EQUIVALENCE (RAD3(1),DDO3N3(1,1)),(RAD4(1),DDO3N4(1,1)) C --- SURFACE ALBEDO (USED FOR THE OLD SCHEME) C O M M O N /SSALB/ 1 ALBD(21,20), ZA(20), TRN(21), DZA(19) COMMON /RDFSAV/ DEGRAD,HSIGMA,DAYSEC,RCO2 C===> ... BEGIN HERE C SOLC,THE SOLAR CONSTANT IS SCALED TO A MORE CURRENT VALUE. C I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN. THEN C CONVERT UNIT TO W/M**2 SSOLAR = SOLC * 0.98 E 0 * 6.97667 E 2 C DO 4000 IRCHNK=1,NRCHNK IBEG = (IRCHNK - 1) * IMAX + 1 IEND = IBEG + IMAX - 1 IF (IEND .GT. 384 ) IEND = 384 IPTS = IEND - IBEG + 1 C C===> ... ASSIGN TEMP,PRESSURES, COSIN OF ZENITH ANGLE C NOTE: THE NMC VARIABLES ARE IN MKS, GFDL LW VARIABLES C ARE IN CGS UNITS, SO PRSSL IS IN DYNS/CM**2. BUT C SW PRSSI IS IN MB. DO 20 I=1,IPTS IR = I + IBEG - 1 PRSSL(I,LP1) = 1.0 E 4 * QS(IR) PRSSI(I,LP1) = 10.0 E 0 * QS(IR) TEMP (I,LP1) = TSFC(IR) COSZEN(I) = COSZRO(IR) C===> ... CURRENTLY THE CONVECTIVE TYPE OF AEROSOL IS NOT IN USE C TO GIVE ZEROES HERE. PAERA(I,6) = 0.0 E 0 20 CONTINUE DO 30 K=1,5 DO 30 I=1,IPTS IR = I + IBEG - 1 PAERA(I,K) = PAERS(IR,K) 30 CONTINUE C===> ... ALL RADIATION VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE. C WHILE THE FORCAST MODEL VARIABLES HAVE K=1 AT THE SURFACE. DO 50 K=1,L DO 50 I=1,IPTS IR = I + IBEG - 1 TEMP (I,K) = TT(IR,LP1-K) PRSSL(I,K) = 1.0 E 4 * SIGL(LP1-K) * QS(IR) PRSSI(I,K) = 10.0 E 0 * SIGI(LP2-K) * QS(IR) RH2O (I,K) = MAX(3.0 E -6, QQH2O(IR,LP1-K)) 50 CONTINUE C**************************************************** C OZONE SECTION C**************************************************** IF (KO3 .GT. 0) THEN DO 60 K=1,L DO 60 I=1,IPTS c Ken+moorthi: set up minimum positive value for O3 QO3(I,K) = max(O3QO3(I+IBEG-1,LP1-K), 1.0E-10) c QO3(I,K) = O3QO3(I+IBEG-1,LP1-K) 60 CONTINUE ELSE DO 80 I=1,IPTS IR = I + IBEG - 1 TH2= 0.2 E 0 * XLAT(IR) * DEGRAD JJROW(I) = 19.001 E 0 - TH2 TTHAN(I) = (19-JJROW(I)) - TH2 80 CONTINUE C===> ... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE, C SEASONAL AND SPATIAL INTERPOLATION DONE BELOW. DO 100 K=1,L DO 100 I=1,IPTS DO3V(I) = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) 1 + RCOS1*DDO3N3(JJROW(I),K) 2 + RCOS2*DDO3N4(JJROW(I),K) DO3VP(I) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) 1 + RCOS1*DDO3N3(JJROW(I)+1,K) 2 + RCOS2*DDO3N4(JJROW(I)+1,K) C===> ... NOW LATITUDINAL INTERPOLATION, AND C CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4) QO3(I,K) = 1.0 E -4 * (DO3V(I)+TTHAN(I)*(DO3VP(I)-DO3V(I))) 100 CONTINUE END IF C****************************************************** C CLOUD OPTICAL PROPERTIES SECTION C****************************************************** C C WRITE(6,102) LAT,IBEG C102 FORMAT(2X,'CALLING CLDPRP FOR LAT, IBEG =',2I6) CALL CLDPRP(IX,PRSSI,TEMP,CLDARY,IBEG,IPTS,XLAT, 1 KTOP,KBTM,NCLDS,CLDLW,TAUCL,CFACSW,CLDSW) C C****************************************************** C SURFACE ALBEDO SECTION C****************************************************** C IF (KALB .EQ. 0) THEN IQ = INT(20.0 E 0 * 0.537 E 0 + 1.0 E 0) DO 110 I=1,IPTS IR = I + IBEG -1 SFCALB(I) = ALBEDO(IR) C===> ... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF C 1) OPEN SEA POINT (SLMSK=0); 2) KALB=0 IF(COSZEN(I).GT.0.0 .AND. SLMSK(IR).EQ.0.0) THEN ZEN = DEGRAD*ACOS(MAX(COSZEN(I),0.0 E 0)) IF(ZEN .GE. 74. E 0) JX = INT(0.5 E 0*(90. E 0-ZEN)+1. E 0) IF(ZEN .LT. 74. E 0 .AND. ZEN .GE. 50. E 0) 1 JX = INT(0.25 E 0*(74. E 0-ZEN) + 9.0 E 0) IF(ZEN.LT.50. E 0) JX = INT(.1 E 0*(50. E 0-ZEN)+15.0 E 0) DZEN = -(ZEN-ZA(JX))/DZA(JX) ALB1 = ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX)) ALB2 = ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX)) SFCALB(I) = ALB1+20. E 0*(ALB2-ALB1)*(0.537 E 0-TRN(IQ)) ENDIF 110 CONTINUE DO 120 I=1,IPTS ALVD(I) = SFCALB(I) ALND(I) = SFCALB(I) ALVB(I) = SFCALB(I) ALNB(I) = SFCALB(I) 120 CONTINUE C===> ... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW C FUNCTION OF COSINE SOLAR ZENITH ANGLE.. DO 130 I=1,IPTS IF (SLMSK(I+IBEG-1).GT.0.0 E 0 .AND. SFCALB(I).LE.0.5 E 0) THE 1N ALBD0 = -18.0 E 0 * (0.5 E 0 - ACOS(COSZEN(I))/ 3.141593E+0 1) ALBD0 = EXP (ALBD0) ALVD1 = (ALVD(I) - 0.054313 E 0) / 0.945687 E 0 ALVB(I) = ALVD1 + (1.0 E 0 - ALVD1) * ALBD0 ALNB(I) = ALVB(I) END IF 130 CONTINUE ELSE DO 150 I=1,IPTS IR = I + IBEG - 1 ALVD(I) = ALBVD(IR) ALND(I) = ALBND(IR) ALVB(I) = ALBVB(IR) ALNB(I) = ALBNB(IR) 150 CONTINUE END IF C*********************************************** C FINAL CHECK BEFORE RADIATION CALLS C*********************************************** IF (IPTS .LT. IMAX) THEN IPTS1 = IPTS + 1 DO 160 I=IPTS1,IMAX COSZEN(I) = COSZEN(IPTS) ALVD(I) = ALVD(IPTS) ALND(I) = ALND(IPTS) ALVB(I) = ALVB(IPTS) ALNB(I) = ALNB(IPTS) 160 CONTINUE DO 170 K=1,LP1 DO 170 I=IPTS1,IMAX PRSSL(I,K) = PRSSL(IPTS,K) PRSSI(I,K) = PRSSI(IPTS,K) TEMP (I,K) = TEMP (IPTS,K) 170 CONTINUE DO 180 K=1,L DO 180 I=IPTS1,IMAX RH2O(I,K) = RH2O(IPTS,K) QO3 (I,K) = QO3 (IPTS,K) 180 CONTINUE END IF C IF(ITIMSW .EQ. 0) GO TO 300 C************************************************* C CALLING CHOU'S SW RADIATION ROUTINE C************************************************* C C===> ... SET TIMER FOR SW RAD CALL C C T00 = SECOND() C OVHD = SECOND() - T00 C TBEF = SECOND() C CALL SWR95(SSOLAR,ISWSRC,PRSSI, 1 TEMP,RH2O,QO3,RCO2,COSZEN,TAUCL, 2 CLDSW,CFACSW,ALVB,ALVD,ALNB,ALND,PAERA, 3 HSW,TSWUC,TSWDC,SSWUC,SSWDC, 4 TSWU0,SSWU0,SSWD0, 5 GDFVB,GDFVD,GDFNB,GDFND) C C TAFT = SECOND() C CPUT = TAFT - TBEF - OVHD C WRITE(6,182) CPUT C182 FORMAT(/3X,'CPU TIME USED BY SW CALL (IN SEC) =',E16.8) C C===> ... SAVE TOA AND SFC FLUXES IN W/M**2 DO 220 I=1,IPTS IR = I + IBEG - 1 TSWUP (IR) = TSWUC(I) TSWDN (IR) = TSWDC(I) SSWUP (IR) = SSWUC(I) SSWDN (IR) = SSWDC(I) TSWUP0(IR) = TSWU0(I) SSWDN0(IR) = SSWD0(I) SSWUP0(IR) = SSWU0(I) C===> ... DIFFUSED DOWNWARD SFC FLUXES (VIS,NIR) SSWFVD(IR) = GDFVD(I) SSWFND(IR) = GDFND(I) C===> ... DIRECT BEAM DOWNWARD SFC FLUXES (VIS,NIR) SSWFVB(IR) = GDFVB(I) SSWFNB(IR) = GDFNB(I) 220 CONTINUE C===> ... CONVERT HEATING RATES TO DEG/SEC DO 240 K=1,L DO 240 I=1,IPTS HTSW(I+IBEG-1,LP1-K) = HSW(I,K) * DAYSEC 240 CONTINUE C 300 IF(ITIMLW .EQ. 0) GO TO 400 C************************************************** C CALLING GFDL LONG WAVE RADIATION ROUTINE C************************************************** C===> ... GET CLD FACTOR FOR LW CALCULATIONS C C TBEF = SECOND() C CALL CLO89(CFACLW,CLDLW,NCLDS,KBTM,KTOP) C CALL LWR88(HLW,SLWNC,TLWUC, 1 SLWN0,TLWU0, 1 PRSSL,TEMP,RH2O,QO3,CFACLW,CLDLW,NCLDS,KTOP,KBTM) C C TAFT = SECOND() C CPUT = TAFT - TBEF - OVHD C WRITE(6,302) CPUT C302 FORMAT(/3X,'CPU TIME USED BY LW CALL (IN SEC) =',E16.8) C C===> ... SAVE TOA AND SFC FLUXES IN W/M**2 DO 320 I=1,IPTS IR = I + IBEG - 1 TLWUP (IR) = 1.0 E -3*TLWUC(I) SLWUP (IR) = 1.0 E -3*HSIGMA*TEMP(I,LP1)**4 SLWDN (IR) = SLWUP(IR) - 1.0 E -3*SLWNC(I) TLWUP0(IR) = 1.0 E -3*TLWU0(I) SLWDN0(IR) = SLWUP(IR) - 1.0 E -3*SLWN0(I) 320 CONTINUE C===> ... CONVERT HEATING RATES TO DEG/SEC DO 340 K=1,L DO 340 I=1,IPTS HTLW(I+IBEG-1,LP1-K) = HLW(I,K) * DAYSEC 340 CONTINUE CYH95.... TEST PRINT OUT C IF (ITM .LE. 40) THEN C ITM = ITM + 1 C WRITE(6,341) IBEG C341 FORMAT(/3X,'LW HEATING RATES CHECK PRINT, IBEG=',I5) C DO 345 K=1,L,2 C WRITE(6,342) K C342 FORMAT(' FROM TOP AND DOWN, LAYER =',I5) C WRITE(6,343) (HLW(I,K),I=1,IPTS,4) C343 FORMAT(16F7.4) C345 CONTINUE CYH95.... TEST PRINT OUT C WRITE(6,241) LAT,IBEG C241 FORMAT(/3X,'SW HEATING RATES CHK PRT, LAT,IBEG=',2i5) C DO 245 K=1,L C WRITE(6,242) K C242 FORMAT(' FROM TOP AND DOWN, LAYER =',I5) C WRITE(6,243) (HSW(I,K),I=1,IPTS,4) C243 FORMAT(16F7.4) C245 CONTINUE C END IF C 400 CONTINUE C 4000 CONTINUE C RETURN END BLOCK DATA GFDLRD C C.... BLOCK DATA INTIALIZES QUANTITIES NEEDED BY THE GFDL CODES. C.... BD2,BD3,BD4,BD5,BLCKFS ALL COMBINED INTO 1 BLOCKDATA FOR FRONTEND. C C BLOCK DATA BD1 GIVES INPUT DATA (TEMPS,PRESSURES,MIXING RATIOS, C CLOUD AMTS AND HEIGHTS) FOR TESTING THE RADIATION CODE AS A C STANDALONE MODEL. COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK BANDTA CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING 10 CM-1 WIDE BANDS.THE 15 UM CO2 COMPLEX C IS 2 BANDS,560-670 AND 670-800 CM-1. OZONE COEFFICIENTS ARE C IN 3 BANDS,670-800 (14.1 UM),990-1070 AND 1070-1200 (9.6 UM). C THE (NBLW) BANDS NOW INCLUDE: C 56 BANDS, 10 CM-1 WIDE 0 - 560 CM-1 C 2 BANDS, 15 UM COMPLEX 560 - 670 CM-1 C 670 - 800 CM-1 C 3 "CONTINUUM" BANDS 800 - 900 CM-1 C 900 - 990 CM-1 C 1070 - 1200 CM-1 C 1 BAND FOR 9.6 UM BAND 990 - 1070 CM-1 C 100 BANDS, 10 CM-1 WIDE 1200 - 2200 CM-1 C 1 BAND FOR 4.3 UM SRC 2270 - 2380 CM-1 C THUS NBLW PRESENTLY EQUALS 163 C ALL BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C C ARNDM = RANDOM "A" PARAMETER FOR (NBLW) BANDS C BRNDM = RANDOM "B" PARAMETER FOR (NBLW) BANDS C BETAD = CONTINUUM COEFFICIENTS FOR (NBLW) BANDS C AP,BP = CAPPHI COEFFICIENTS FOR (NBLW) BANDS C ATP,BTP = CAPPSI COEFFICIENTS FOR (NBLW) BANDS C BANDLO = LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C BANDHI = HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C AO3RND = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3RND = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15 = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C DATA FOR ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND ARE OBTAINED BY C USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS ARE FROM C ROBERTS (1976). COMMON / BANDTA / ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW), 1 BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW), 2 BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2) C C COMMON BLOCK BDWIDE CONTAINS RANDOM BAND PARAMETERS FOR SPECIFIC C WIDE BANDS. AT PRESENT,THE INFORMATION CONSISTS OF 1) RANDOM C MODEL PARAMETERS FOR THE 15 UM BAND,560-800 CM-1; 2) THE C CONTINUUM COEFFICIENT FOR THE 800-990,1070-1200 CM-1 BAND C SPECIFICALLY: C AWIDE = RANDOM "A" PARAMETER FOR BAND C BWIDE = RANDOM "B" PARAMETER FOR BAND C BETAWD = CONTINUUM COEFFICIENTS FOR BAND C APWD,BPWD = CAPPHI COEFFICIENTS FOR BAND C ATPWD,BTPWD = CAPPSI COEFFICIENTS FOR BAND C BDLOWD = LOWEST FREQUENCY IN EACH FREQ BAND C BDHIWD = HIGHEST FREQUENCY IN EACH FREQ BAND C AB15WD = THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINW = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C SKO2D = 1./BETINW, USED IN SPA88 FOR CONT. COEFFS C SKC1R = BETAWD/BETINW, USED FOR CONT. COEFF. FOR C 15 UM BAND IN FST88 C SKO3R = RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO C BETINW, USED FOR 9.6 UM CONT COEFF IN FST88 C DATA FOR AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). COMMON / BDWIDE / AWIDE,BWIDE,BETAWD, 1 APWD,BPWD,ATPWD,BTPWD, 2 BDLOWD,BDHIWD,BETINW, 3 AB15WD,SKO2D,SKC1R,SKO3R C C COMMON BLOCK BDCOMB CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING COMBINED WIDE FREQUENCY BANDS BETWEEN 160 AND C 1200 CM-1,AS WELL AS THE 2270-2380 BAND FOR SOURCE CALC. C BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1 C BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS) C FOR 560-1200 CM-1 C BAND 15: FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE C CALCULATION ONLY C THUS NBLY PRESENTLY EQUALS 15 C C BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C ACOMB = RANDOM "A" PARAMETER FOR (NBLY) BANDS C BCOMB = RANDOM "B" PARAMETER FOR (NBLY) BANDS C BETACM = CONTINUUM COEFFICIENTS FOR (NBLY) BANDS C APCM,BPCM = CAPPHI COEFFICIENTS FOR (NBLY) BANDS C ATPCM,BTPCM = CAPPSI COEFFICIENTS FOR (NBLY) BANDS C BDLOCM = LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C BDHICM = HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C AO3CM = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3CM = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15CM = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINC = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C IBAND = INDEX NO OF THE 40 WIDE BANDS USED IN C COMBINED WIDE BAND CALCULATIONS. IN OTHER C WORDS,INDEX TELLING WHICH OF THE 40 WIDE C BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN C EACH OF THE FIRST 8 COMBINED WIDE BANDS C DATA FOR ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). IBAND INDEX VALUES ARE OBTAINED BY C EXPERIMENTATION. COMMON / BDCOMB / IBAND(40),ACOMB(NBLY),BCOMB(NBLY), 1 BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), 2 BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC, 3 AO3CM(3),BO3CM(3),AB15CM(2) C C THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION C FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND C SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985), C***COMMON CO2BD3 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED C ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE C DATA ARE IN BLOCK DATA BD3: C CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251 C CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258 C C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251 C C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251 C CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE C LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR C NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB C CO2M58 = SAME AS CO2M51,WITH P(SFC)= ^810 MB C CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51 C CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58 C C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51 C C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58 C STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL C STRUCTURE WITH P(SFC)=1013.25 MB C GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL C STRUCTURE WITH P(SFC)=1013.25 MB. C B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN. C CORRECTION FOR T(K). (SEE REF. 4 AND BD3) C B1 = TEMP. COEFFICIENT, USED ALONG WITH B0 C B2 = TEMP. COEFFICIENT, USED ALONG WITH B0 C B3 = TEMP. COEFFICIENT, USED ALONG WITH B0 C COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1), 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L), 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L), 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3 C C***COMMON CO2BD2 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM C CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2. C CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231 C CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238 C C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231 C C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231 C COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1), 1 CDT38(LP1),C2D31(LP1),C2D38(LP1) C C***COMMON CO2BD4 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM C CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4. C CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271 C CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278 C C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271 C C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271 C COMMON / CO2BD4 / CO271(LP1),CO278(LP1),CDT71(LP1), 1 CDT78(LP1),C2D71(LP1),C2D78(LP1) C C***COMMON CO2BD5 CONTAINS CO2 TRANSMISSION FUNCTIONS FOR THE 2270- C 2380 PART OF THE 4.3 UM CO2 BAND. THESE DATA ARE IN BLOCK DATA BD5. C CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C COMMON / CO2BD5 / CO211(LP1),CO218(LP1) C COMMON/TBLTMP/ DELCM(NBLY) C*** NOTE: THE DATA,EQUIVALENCE AND DIMENSION STATEMENTS FOR QUANTITIES C EQUIVALENCED TO COMMON BLOCK BANDTA DEPEND ON THE VALUE OF THE C PARAMETER NBLW. C DIMENSION ARNDM1(64),ARNDM2(64),ARNDM3(35) DIMENSION BRNDM1(64),BRNDM2(64),BRNDM3(35) DIMENSION AP1(64),AP2(64),AP3(35) DIMENSION BP1(64),BP2(64),BP3(35) DIMENSION ATP1(64),ATP2(64),ATP3(35) DIMENSION BTP1(64),BTP2(64),BTP3(35) DIMENSION BETAD1(64),BETAD2(64),BETAD3(35) DIMENSION BANDL1(64),BANDL2(64),BANDL3(35) DIMENSION BANDH1(64),BANDH2(64),BANDH3(35) EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), 1 (ARNDM3(1),ARNDM(129)) EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), 1 (BRNDM3(1),BRNDM(129)) EQUIVALENCE (AP1(1),AP(1)),(AP2(1),AP(65)), 1 (AP3(1),AP(129)) EQUIVALENCE (BP1(1),BP(1)),(BP2(1),BP(65)), 1 (BP3(1),BP(129)) EQUIVALENCE (ATP1(1),ATP(1)),(ATP2(1),ATP(65)), 1 (ATP3(1),ATP(129)) EQUIVALENCE (BTP1(1),BTP(1)),(BTP2(1),BTP(65)), 1 (BTP3(1),BTP(129)) EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), 1 (BETAD3(1),BETAD(129)) EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), 1 (BANDL3(1),BANDLO(129)) EQUIVALENCE (BANDH1(1),BANDHI(1)),(BANDH2(1),BANDHI(65)), 1 (BANDH3(1),BANDHI(129)) C C***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING C THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS DATA ARNDM1 / * 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, * 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, * 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, * 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, * 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, * 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, * 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, * 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, * 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, * 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, * 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, * 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, * 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, * 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, * 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, * 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/ DATA ARNDM2 / * 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, * 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, * 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, * 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, * 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, * 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, * 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, * 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, * 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, * 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, * 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, * 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, * 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, * 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, * 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, * 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/ DATA ARNDM3 / * 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, * 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, * 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, * 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, * 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, * 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, * 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, * 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, * 0.919409E-01, 0.155521E-01, 0.537083E-02/ DATA BRNDM1 / * 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, * 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, * 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, * 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, * 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, * 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, * 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, * 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, * 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, * 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, * 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, * 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, * 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, * 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, * 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, * 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/ DATA BRNDM2 / * 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, * 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, * 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, * 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, * 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, * 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, * 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, * 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, * 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, * 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, * 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, * 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, * 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, * 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, * 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, * 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/ DATA BRNDM3 / * 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, * 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, * 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, * 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, * 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, * 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, * 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, * 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, * 0.227233E+00, 0.190562E+00, 0.214005E+00/ DATA AP1 / * -0.675950E-02, -0.909459E-02, -0.800214E-02, -0.658673E-02, * -0.245580E-02, -0.710464E-02, -0.205565E-02, -0.446529E-02, * -0.440265E-02, -0.593625E-02, -0.201913E-02, -0.349169E-02, * -0.209324E-02, -0.127980E-02, -0.388007E-02, -0.140542E-02, * 0.518346E-02, -0.159375E-02, 0.250508E-02, 0.132182E-01, * -0.903779E-03, 0.110959E-01, 0.924528E-03, 0.207428E-01, * 0.364166E-02, 0.365229E-02, 0.884367E-02, 0.617260E-02, * 0.701340E-02, 0.184265E-01, 0.992822E-02, 0.908582E-02, * 0.106581E-01, 0.276268E-02, 0.158414E-01, 0.145747E-01, * 0.453080E-02, 0.214767E-01, 0.553895E-02, 0.195031E-01, * 0.237016E-01, 0.112371E-01, 0.275977E-01, 0.188833E-01, * 0.131079E-01, 0.130019E-01, 0.385122E-01, 0.111768E-01, * 0.622620E-02, 0.194397E-01, 0.134360E-01, 0.207829E-01, * 0.147960E-01, 0.744479E-02, 0.107564E-01, 0.181562E-01, * 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, * 0.279259E-01, 0.197002E-01, 0.140268E-01, 0.185933E-01/ DATA AP2 / * 0.169525E-01, 0.214410E-01, 0.136577E-01, 0.169510E-01, * 0.173025E-01, 0.958346E-02, 0.255024E-01, 0.308943E-01, * 0.196031E-01, 0.183608E-01, 0.149419E-01, 0.206358E-01, * 0.140654E-01, 0.172797E-01, 0.145470E-01, 0.982987E-02, * 0.116695E-01, 0.811333E-02, 0.965823E-02, 0.649977E-02, * 0.462192E-02, 0.545929E-02, 0.680407E-02, 0.291235E-02, * -0.974773E-03, 0.341591E-02, 0.376198E-02, 0.770610E-03, * -0.940864E-04, 0.514532E-02, 0.232371E-02, -0.177741E-02, * -0.374892E-03, -0.370485E-03, -0.221435E-02, -0.490000E-02, * 0.588664E-02, 0.931411E-03, -0.456043E-03, -0.545576E-02, * -0.421136E-02, -0.353742E-02, -0.174276E-02, -0.361246E-02, * -0.337822E-02, -0.867030E-03, -0.118001E-02, -0.222405E-02, * -0.725144E-03, 0.118483E-02, 0.995087E-02, 0.273812E-03, * 0.417298E-02, 0.764294E-02, 0.631568E-02, -0.213528E-02, * 0.746130E-02, 0.110337E-02, 0.153157E-01, 0.504532E-02, * 0.406047E-02, 0.192895E-02, 0.202058E-02, 0.126420E-01/ DATA AP3 / * 0.310028E-02, 0.214779E-01, 0.560165E-02, 0.661070E-02, * 0.694966E-02, 0.539194E-02, 0.103745E-01, 0.180150E-01, * 0.747133E-02, 0.114927E-01, 0.115213E-01, 0.160709E-02, * 0.154278E-01, 0.112067E-01, 0.148690E-01, 0.154442E-01, * 0.123977E-01, 0.237539E-01, 0.162820E-01, 0.269484E-01, * 0.178081E-01, 0.143221E-01, 0.262468E-01, 0.217065E-01, * 0.107083E-01, 0.281220E-01, 0.115565E-01, 0.231244E-01, * 0.225197E-01, 0.178624E-01, 0.327708E-01, 0.116657E-01, * 0.277452E-01, 0.301647E-01, 0.349782E-01/ DATA BP1 / * 0.717848E-05, 0.169280E-04, 0.126710E-04, 0.758397E-05, * -0.533900E-05, 0.143490E-04, -0.595854E-05, 0.296465E-05, * 0.323446E-05, 0.115359E-04, -0.692861E-05, 0.131477E-04, * -0.624945E-05, -0.756955E-06, 0.107458E-05, -0.159796E-05, * -0.290529E-04, -0.170918E-05, -0.193934E-04, -0.707209E-04, * -0.148154E-04, -0.383162E-04, -0.186050E-04, -0.951796E-04, * -0.210944E-04, -0.330590E-04, -0.373087E-04, -0.408972E-04, * -0.396759E-04, -0.827756E-04, -0.573773E-04, -0.325384E-04, * -0.449411E-04, -0.271450E-04, -0.752791E-04, -0.549699E-04, * -0.225655E-04, -0.102034E-03, -0.740322E-05, -0.668846E-04, * -0.106063E-03, -0.304840E-04, -0.796023E-04, 0.504880E-04, * 0.486384E-04, -0.531946E-04, -0.147771E-03, -0.406785E-04, * 0.615750E-05, -0.486264E-04, -0.419335E-04, -0.819467E-04, * -0.709498E-04, 0.326984E-05, -0.369743E-04, -0.526848E-04, * -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, * -0.982953E-04, -0.772497E-04, -0.119430E-05, -0.655187E-04/ DATA BP2 / * -0.339078E-04, 0.716657E-04, -0.335893E-04, 0.220239E-04, * -0.491012E-04, -0.393325E-04, -0.626461E-04, -0.795479E-04, * -0.599181E-04, -0.578153E-04, -0.597559E-05, -0.866750E-04, * -0.486783E-04, -0.580912E-04, -0.647368E-04, -0.350643E-04, * -0.566635E-04, -0.385738E-04, -0.463782E-04, -0.321485E-04, * -0.177300E-04, -0.250201E-04, -0.365492E-04, -0.165218E-04, * -0.649177E-05, -0.218458E-04, -0.984604E-05, -0.120034E-04, * -0.110119E-06, -0.164405E-04, -0.141396E-04, 0.315347E-05, * -0.141544E-05, -0.297320E-05, -0.216248E-05, 0.839264E-05, * -0.178197E-04, -0.106225E-04, -0.468195E-05, 0.997043E-05, * 0.679709E-05, 0.324610E-05, -0.367325E-05, 0.671058E-05, * 0.509293E-05, -0.437392E-05, -0.787922E-06, -0.271503E-06, * -0.437940E-05, -0.128205E-04, -0.417830E-04, -0.561134E-05, * -0.209940E-04, -0.414366E-04, -0.289765E-04, 0.680406E-06, * -0.558644E-05, -0.530395E-05, -0.622242E-04, -0.159979E-05, * -0.140286E-04, -0.128463E-04, -0.929499E-05, -0.327886E-04/ DATA BP3 / * -0.189353E-04, -0.737589E-04, -0.323471E-04, -0.272502E-04, * -0.321731E-04, -0.326958E-04, -0.509157E-04, -0.681890E-04, * -0.362182E-04, -0.354405E-04, -0.578392E-04, 0.238627E-05, * -0.709028E-04, -0.518717E-04, -0.491859E-04, -0.718017E-04, * -0.418978E-05, -0.940819E-04, -0.630375E-04, -0.478469E-04, * -0.751896E-04, -0.267113E-04, -0.109019E-03, -0.890983E-04, * -0.177301E-04, -0.120216E-03, 0.220464E-04, -0.734277E-04, * -0.868068E-04, -0.652319E-04, -0.136982E-03, -0.279933E-06, * -0.791824E-04, -0.111781E-03, -0.748263E-04/ DATA ATP1 / * -0.722782E-02, -0.901531E-02, -0.821263E-02, -0.808024E-02, * -0.320169E-02, -0.661305E-02, -0.287272E-02, -0.486143E-02, * -0.242857E-02, -0.530288E-02, -0.146813E-02, -0.566474E-03, * -0.102192E-02, 0.300643E-03, -0.331655E-02, 0.648220E-03, * 0.552446E-02, -0.933046E-03, 0.205703E-02, 0.130638E-01, * -0.229828E-02, 0.715648E-02, 0.444446E-03, 0.193500E-01, * 0.364119E-02, 0.252713E-02, 0.102420E-01, 0.494224E-02, * 0.584934E-02, 0.146255E-01, 0.921986E-02, 0.768012E-02, * 0.916105E-02, 0.276223E-02, 0.125245E-01, 0.131146E-01, * 0.793016E-02, 0.201536E-01, 0.658631E-02, 0.171711E-01, * 0.228470E-01, 0.131306E-01, 0.226658E-01, 0.176086E-01, * 0.149987E-01, 0.143060E-01, 0.313189E-01, 0.117070E-01, * 0.133522E-01, 0.244259E-01, 0.148393E-01, 0.223982E-01, * 0.151792E-01, 0.180474E-01, 0.106299E-01, 0.191016E-01, * 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, * 0.281662E-01, 0.199525E-01, 0.192588E-01, 0.173220E-01/ DATA ATP2 / * 0.195220E-01, 0.169371E-01, 0.193212E-01, 0.145558E-01, * 0.189654E-01, 0.122030E-01, 0.186206E-01, 0.228842E-01, * 0.139343E-01, 0.164006E-01, 0.137276E-01, 0.154005E-01, * 0.114575E-01, 0.129956E-01, 0.115305E-01, 0.929260E-02, * 0.106359E-01, 0.771623E-02, 0.106075E-01, 0.597630E-02, * 0.493960E-02, 0.532554E-02, 0.646175E-02, 0.302693E-02, * 0.150899E-02, 0.310333E-02, 0.533734E-02, 0.239094E-03, * 0.356782E-02, 0.707574E-02, 0.215758E-02, -0.527589E-03, * 0.643893E-03, -0.101916E-02, -0.383336E-02, -0.445966E-02, * 0.880190E-02, 0.245662E-02, -0.560923E-03, -0.582201E-02, * -0.323233E-02, -0.454197E-02, -0.240905E-02, -0.343160E-02, * -0.335156E-02, -0.623846E-03, 0.393633E-03, -0.271593E-02, * -0.675874E-03, 0.920642E-03, 0.102168E-01, -0.250663E-03, * 0.437126E-02, 0.767434E-02, 0.569931E-02, -0.929326E-03, * 0.659414E-02, 0.280687E-02, 0.127614E-01, 0.780789E-02, * 0.374807E-02, 0.274288E-02, 0.534940E-02, 0.104349E-01/ DATA ATP3 / * 0.294379E-02, 0.177846E-01, 0.523249E-02, 0.125339E-01, * 0.548538E-02, 0.577403E-02, 0.101532E-01, 0.170375E-01, * 0.758396E-02, 0.113402E-01, 0.106960E-01, 0.107782E-01, * 0.136148E-01, 0.992064E-02, 0.167276E-01, 0.149603E-01, * 0.136259E-01, 0.234521E-01, 0.166806E-01, 0.298505E-01, * 0.167592E-01, 0.186679E-01, 0.233062E-01, 0.228467E-01, * 0.128947E-01, 0.293979E-01, 0.219815E-01, 0.220663E-01, * 0.272710E-01, 0.237139E-01, 0.331743E-01, 0.208799E-01, * 0.281472E-01, 0.318440E-01, 0.370962E-01/ DATA BTP1 / * 0.149748E-04, 0.188007E-04, 0.196530E-04, 0.124747E-04, * -0.215751E-07, 0.128357E-04, -0.265798E-05, 0.606262E-05, * 0.287668E-05, 0.974612E-05, -0.833451E-05, 0.584410E-05, * -0.452879E-05, -0.782537E-05, 0.786165E-05, -0.768351E-05, * -0.196168E-04, 0.177297E-06, -0.129258E-04, -0.642798E-04, * -0.986297E-05, -0.257145E-04, -0.141996E-04, -0.865089E-04, * -0.141691E-04, -0.272578E-04, -0.295198E-04, -0.308878E-04, * -0.313193E-04, -0.669272E-04, -0.475777E-04, -0.221332E-04, * -0.419930E-04, -0.102519E-04, -0.590184E-04, -0.574771E-04, * -0.240809E-04, -0.913994E-04, -0.908886E-05, -0.721074E-04, * -0.902837E-04, -0.447582E-04, -0.664544E-04, -0.143150E-04, * -0.511866E-05, -0.559352E-04, -0.104734E-03, -0.305206E-04, * 0.103303E-04, -0.613019E-04, -0.320040E-04, -0.738909E-04, * -0.388263E-04, 0.306515E-04, -0.352214E-04, -0.253940E-04, * -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, * -0.933645E-04, -0.664045E-04, -0.570712E-05, -0.566312E-04/ DATA BTP2 / * -0.364967E-04, 0.393501E-06, -0.234050E-04, -0.141317E-04, * -0.525480E-04, -0.172241E-04, -0.410843E-04, -0.358348E-04, * -0.256168E-04, -0.509482E-04, -0.180570E-04, -0.555356E-04, * -0.271464E-04, -0.274040E-04, -0.480889E-04, -0.275751E-04, * -0.415681E-04, -0.383770E-04, -0.280139E-04, -0.287919E-04, * -0.125865E-04, -0.265467E-04, -0.172765E-04, -0.164611E-04, * 0.189183E-04, -0.171219E-04, -0.132766E-04, -0.344611E-05, * -0.442832E-05, -0.185779E-04, -0.139755E-04, 0.168083E-05, * -0.395287E-05, -0.297871E-05, 0.434383E-05, 0.131741E-04, * -0.192637E-04, -0.549551E-05, 0.122553E-05, 0.204627E-04, * 0.154027E-04, 0.953462E-05, 0.131125E-05, 0.732839E-05, * 0.755405E-05, -0.305552E-05, -0.434858E-05, 0.308409E-05, * -0.164787E-05, -0.818533E-05, -0.355041E-04, -0.504696E-05, * -0.229022E-04, -0.356891E-04, -0.230346E-04, 0.518835E-05, * -0.160187E-04, -0.104617E-04, -0.464754E-04, -0.115807E-04, * -0.130230E-04, -0.603491E-05, -0.125324E-04, -0.165516E-04/ DATA BTP3 / * -0.991679E-05, -0.529432E-04, -0.200199E-04, -0.181977E-04, * -0.220940E-04, -0.204483E-04, -0.432584E-04, -0.449109E-04, * -0.247305E-04, -0.174253E-04, -0.484446E-04, 0.354150E-04, * -0.425581E-04, -0.406562E-04, -0.505495E-04, -0.651856E-04, * -0.153953E-04, -0.894294E-04, -0.616551E-04, -0.846504E-04, * -0.699414E-04, -0.376203E-04, -0.940985E-04, -0.753050E-04, * -0.183710E-04, -0.123907E-03, -0.279347E-04, -0.736381E-04, * -0.103588E-03, -0.754117E-04, -0.140991E-03, -0.366687E-04, * -0.927785E-04, -0.125321E-03, -0.115290E-03/ DATA BETAD1 / * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, * 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, * 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, * 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, * 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, * 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/ DATA BETAD2 / * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/ DATA BETAD3 / * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.000000E+00, 0.000000E+00, 0.000000E+00/ DATA BANDL1 / * 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, * 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, * 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, * 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, * 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, * 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, * 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, * 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, * 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, * 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, * 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, * 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, * 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, * 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, * 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, * 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/ DATA BANDL2 / * 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, * 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, * 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, * 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, * 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, * 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, * 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, * 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, * 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, * 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, * 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, * 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, * 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, * 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, * 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, * 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/ DATA BANDL3 / * 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, * 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, * 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, * 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, * 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, * 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, * 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, * 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, * 0.218000E+04, 0.219000E+04, 0.227000E+04/ DATA BANDH1 / * 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, * 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, * 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, * 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, * 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, * 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, * 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, * 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, * 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, * 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, * 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, * 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, * 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, * 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, * 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, * 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/ DATA BANDH2 / * 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, * 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, * 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, * 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, * 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, * 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, * 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, * 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, * 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, * 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, * 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, * 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, * 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, * 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, * 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, * 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/ DATA BANDH3 / * 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, * 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, * 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, * 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, * 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, * 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, * 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, * 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, * 0.219000E+04, 0.220000E+04, 0.238000E+04/ DATA AO3RND / * 0.543368E+02, 0.234676E+04, 0.384881E+02/ DATA BO3RND / * 0.526064E+01, 0.922424E+01, 0.496515E+01/ DATA AWIDE / * 0.309801E+01/ DATA BWIDE / * 0.495357E-01/ DATA APWD / * 0.177115E-01/ DATA BPWD / * -0.545226E-04/ DATA ATPWD / * 0.187967E-01/ DATA BTPWD / * -0.567449E-04/ DATA BETAWD / * 0.347839E+02/ DATA BETINW / * 0.766811E+01/ DATA BDLOWD / * 0.560000E+03/ DATA BDHIWD / * 0.800000E+03/ DATA ACOMB / * 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, * 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, * 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, * 0.178110E-01, 0.170166E+00, 0.537083E-02/ DATA BCOMB / * 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, * 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, * 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, * 0.875182E-01, 0.857907E-01, 0.214005E+00/ DATA APCM / * -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, * 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, * 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, * 0.279259E-01, 0.197002E-01, 0.349782E-01/ DATA BPCM / * -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, * -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, * -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, * -0.982953E-04, -0.772497E-04, -0.748263E-04/ DATA ATPCM / * -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, * 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, * 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, * 0.281662E-01, 0.199525E-01, 0.370962E-01/ DATA BTPCM / * -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, * -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, * -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, * -0.933645E-04, -0.664045E-04, -0.115290E-03/ DATA BETACM / * 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, * 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, * 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, * 0.589554E+01, 0.495227E+01, 0.000000E+00/ DATA DELCM / * 0.300000E+02, 0.110000E+03, 0.600000E+02, 0.400000E+02, * 0.200000E+02, 0.500000E+02, 0.400000E+02, 0.500000E+02, * 0.110000E+03, 0.130000E+03, 0.100000E+03, 0.900000E+02, * 0.800000E+02, 0.130000E+03, 0.110000E+03/ DATA IBAND / * 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, * 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, * 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, * 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/ C***THE FOLLOWING DATA ARE LEVEL-INDEPENDENT CCCCC DATA RCO2/3.3E-4/ DATA G/980.665/ CCCCC DATA CTAUDA/.5/ CCCCC DATA CSOLAR/1.96/ CCCCC DATA CCOSZ/.5/ C B0,B1,B2,B3 ARE COEFFICIENTS USED TO CORRECT FOR THE USE OF 250K IN C THE PLANCK FUNCTION USED IN EVALUATING PLANCK-WEIGHTED CO2 C TRANSMISSION FUNCTIONS. (SEE REF. 4) DATA B0,B1,B2,B3/-.51926410E-4,-.18113332E-3, 1 -.10680132E-5,-.67303519E-7/ C ******************************************************************* C * * C * B L C K F S FROM G F D L * C * UNUSED DATA CLEANED OUT - NOV 86 AND MAR 89 ..K.A.CAMPANA.... * C * * C ******************************************************************* C C FOR SEASONAL VARIATION C SEASON=1,2,3,4 FOR WINTER,SPRING,SUMMER,FALL ONLY (NOT ACTIVE) C SEASON=5 - SEASONAL VARIATION(I.E.INTERPOLATE TO DAY OF FCST) C INTEGER SEASON COMMON/DIUCON/SEASON,LSEASON,FCSTDA,JTIME(5),LJTIME,DAZ(12),JDNMC, . LJDNMC, . FJDNMC,TSLAG,RLAG,TIMIN,TPI,HPI,YEAR,DAY,DHR,IXXXX, . LIXXXX DATA SEASON/5/ DATA TSLAG/45.25/, RLAG/14.8125/ DATA DAY/86400./, YEAR/365.25/ DATA TPI/6.283185308/, HPI/1.570796327/ DATA JTIME/0,1,0,0,0/ DATA DHR/2./ DATA DAZ/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./ C C SEA SURFACE ALBEDO DATA C COMMON/SSALB/ALBD(21,20),ZA(20),TRN(21),DZA(19) DIMENSION ALB1(21,7),ALB2(21,7),ALB3(21,6) EQUIVALENCE (ALB1(1,1),ALBD(1,1)),(ALB2(1,1),ALBD(1,8)), . (ALB3(1,1),ALBD(1,15)) DATA ALB1/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, . .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, . .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, . .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, . .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, . .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, . .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, . .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, . .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, . .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, . .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, . .246,.235,.222,.211,.205,.200/ DATA ALB2/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, . .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, . .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, . .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, . .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, . .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, . .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, . .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, . .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, . .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, . .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, . .058,.055,.054,.053,.052,.052/ DATA ALB3/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, . .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, . .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, . .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, . .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, . .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, . .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, . .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, . .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, . .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/ DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., . 50.,40.,30.,20.,10.,0.0/ DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, . .70,.75,.80,.85,.90,.95,1.00/ DATA DZA/8*2.0,6*4.0,5*10.0/ C COMMON/TABLES/SC COMMON /SWRSAV/ ABCFF(NB),PWTS(NB),CFCO2,CFO3,REFLO3,RRAYAV C DATA SC/2.0/ C C CHANGED TO CONFORM AMIP-II SPECIFICATIN OF 1365 W/M**2 C DATA SC/1.9964498/ C---SPECIFICATION OF DATA STATEMENTS: C ABCFF=ABSORPTION COEFFICIENTS FOR BANDS IN K-DISTRI- C BUTION. ORIGINALLY GIVEN BY LACIS AND HANSEN, REVISED BY C RAMASWAMY C PWTS=CORRESPONDING WEIGHTS ASSIGNED TO BANDS IN THE C K-DISTRIBUTION C REFLO3,RRAYAV= REFLECTION COEFFICIENTS GIVEN BY C LACIS AND HANSEN TO ACCOUNT FOR EFFECTS OF RAYLEIGH SCATTERING C IN THE VISIBLE FREQUENCIES (BAND 1) C CFCO2,CFO3=CONVERSION FACTORS FROM GM/CM**2 TO CM-ATM(STP) C C---THE FOLLOWING ARE THE COEFFICIENTS FOR THE 12-BAND SHORTWAVE C RADIATION CODE, SPECIFIED BY RAMASWAMY. DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., 1 989.,2706.,39011./ DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, 1 .001467,.002342,.001075/ C---THE ORIGINAL 9-BAND LACIS-HANSEN COEFFICIENTS ARE GIVEN HERE; IT C THE USER INSISTS ON USING THESE VALUES, SHE MUST ALSO CHANGE C THE PARAMETER NB FROM 12 TO 9. THIS PARAMETER IS DEFINED IN C RDPARM.H . NO OTHER CHANGES ARE REQUIRED! C DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190./ C DATA PWTS/.5000,.1470,.0698,.1443,.0584,.0335,.0225,.0158,.0087/ C DATA CFCO2,CFO3/508.96,466.64/ DATA REFLO3/1.9/ DATA RRAYAV/0.144/ END SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP) CFPP$ NOCONCUR R C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C SUBROUTINE CLO88 COMPUTES CLOUD TRANSMISSION FUNCTIONS FOR THE C LONGWAVE CODE,USING CODE WRITTEN BY BERT KATZ (301-763-8161). C AND MODIFIED BY DAN SCHWARZKOPF IN DECEMBER,1988. C INPUTS: (COMMON BLOCK) C CAMT,KTOP,KBTM,NCLDS RADISW C OUTPUT: C CLDFAC CLDCOM C C CALLED BY: RADMN OR MODEL ROUTINE C CALLS : C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C DIMENSION NCLDS(IMAX),KTOP(IMBX,LP1),KBTM(IMBX,LP1) DIMENSION CAMT(IMBX,LP1),CLDFAC(IMBX,LP1,LP1) DIMENSION CLDROW(LP1) C C DIMENSION CLDFIP(LP1,LP1) DIMENSION CLDIPT(LP1,LP1, 64 ) C DO 1 IQ=1,IMAX, 64 ITOP=IQ+( 64 -1) IF(ITOP.GT.IMAX) ITOP=IMAX JTOP=ITOP-IQ+1 DO 11 IP=1,JTOP IR=IQ+IP-1 IF (NCLDS(IR).EQ.0) THEN DO 25 J=1,LP1 DO 25 I=1,LP1 CLDIPT(I,J,IP)=1. 25 CONTINUE ENDIF IF (NCLDS(IR).GE.1) THEN XCLD=1.-CAMT(IR,2) K1=KTOP(IR,2)+1 K2=KBTM(IR,2) DO 27 J=1,LP1 CLDROW(J)=1. 27 CONTINUE DO 29 J=1,K2 CLDROW(J)=XCLD 29 CONTINUE KB=MAX(K1,K2+1) DO 33 K=KB,LP1 DO 33 KP=1,LP1 CLDIPT(KP,K,IP)=CLDROW(KP) 33 CONTINUE DO 37 J=1,LP1 CLDROW(J)=1. 37 CONTINUE DO 39 J=K1,LP1 CLDROW(J)=XCLD 39 CONTINUE KT=MIN(K1-1,K2) DO 43 K=1,KT DO 43 KP=1,LP1 CLDIPT(KP,K,IP)=CLDROW(KP) 43 CONTINUE IF(K2+1.LE.K1-1) THEN DO 31 J=K2+1,K1-1 DO 31 I=1,LP1 CLDIPT(I,J,IP)=1. 31 CONTINUE ELSE IF(K1.LE.K2) THEN DO 32 J=K1,K2 DO 32 I=1,LP1 CLDIPT(I,J,IP)=XCLD 32 CONTINUE ENDIF ENDIF IF (NCLDS(IR).GE.2) THEN DO 21 NC=2,NCLDS(IR) XCLD=1.-CAMT(IR,NC+1) K1=KTOP(IR,NC+1)+1 K2=KBTM(IR,NC+1) DO 47 J=1,LP1 CLDROW(J)=1. 47 CONTINUE DO 49 J=1,K2 CLDROW(J)=XCLD 49 CONTINUE KB=MAX(K1,K2+1) DO 53 K=KB,LP1 DO 53 KP=1,LP1 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP) C CLDFIP(KP,K)=CLDROW(KP) 53 CONTINUE DO 57 J=1,LP1 CLDROW(J)=1. 57 CONTINUE DO 59 J=K1,LP1 CLDROW(J)=XCLD 59 CONTINUE KT=MIN(K1-1,K2) DO 63 K=1,KT DO 63 KP=1,LP1 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP) C CLDFIP(KP,K)=CLDROW(KP) 63 CONTINUE C IF(K2+1.LE.K1-1) THEN C DO 51 J=K2+1,K1-1 C DO 51 I=1,LP1 C CLDIPT(I,J,IP)=1. C51 CONTINUE IF(K1.LE.K2) THEN DO 52 J=K1,K2 DO 52 I=1,LP1 CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD 52 CONTINUE ENDIF C DO 65 J=1,LP1 C DO 65 I=1,LP1 C CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*CLDFIP(I,J) C65 CONTINUE 21 CONTINUE ENDIF 11 CONTINUE DO 71 J=1,LP1 DO 71 I=1,LP1 DO 71 IP=1,JTOP IR=IQ+IP-1 CLDFAC(IR,I,J)=CLDIPT(I,J,IP) 71 CONTINUE 1 CONTINUE RETURN END SUBROUTINE CONRAD(NFILE,RCO2) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CONRAD INITIALIZES ARRAYS FOR -LW- RADIATION C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: READS CO2 TRANSMISSION FUNCTION DATA(FROM EXTERNAL FILE), C WHICH HAS BEEN PRE-COMPUTED FOR CURRENT VERTICAL COORDINATE ON C THE FRONT-END MACHINE. WORD CONVERSION BETWEEN FRONT-END AND C205 C OCCURS HERE. ALSO CALL TABL86 TO SET UP TABLES FOR LW CALCULATION C THIS CODE (CONRAD) IS ONLY CALLED ONCE... C C PROGRAM HISTORY LOG: C 84-01-01 FELS AND SCHWARZKOPF,GFDL. C 89-07-07 KENNETH CAMPANA - REMOVED UNNECESSARY CODE AND ADDED C READING AND WORD CONVERSION OF CO2 DATA. C 89-11-29 KENNETH CAMPANA - COMMENTED CO2 READS BECAUSE THEY C ARE NOT YET READY FOR THE NEW GFDL LW. C C USAGE: CALL CONRAD(NFILE) C INPUT ARGUMENT LIST: C NFILE - INTEGER NAME OF EXTERNAL CO2 FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ C ******************************************************************* C * C O N R A D * C * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL * C * COORDINATE TESTS ... * C * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 * C ******************************************************************* C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) DIMENSION SGTMP(LP1,2),CO21D(L,6),CO22D(LP1,LP1,6) DIMENSION CO21D3(LP1,6),CO21D7(LP1,6) C C CO2 DATA TABLES FOR USER''S VERTICAL COORDINATE C C THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION C FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND C SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985), C----- THE 2-DIMENSIONAL ARRAYS ARE C CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES C FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982 C MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED C TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A C 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN C SCHWARZKOPF AND FELS (J.G.R.,1985). C----- THE 1-DIM ARRAYS ARE C CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES C FOR TAU(I,I+1),I=1,L, C WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE C ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. C THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O. C----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/ C 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR C PSTAR=1013250. C----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS C USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM) C THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION C FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND C SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985), C***COMMON CO2BD3 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED C ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE C DATA ARE IN BLOCK DATA BD3: C CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251 C CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258 C C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251 C C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251 C CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE C LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR C NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB C CO2M58 = SAME AS CO2M51,WITH P(SFC)= ^810 MB C CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51 C CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58 C C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51 C C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58 C STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL C STRUCTURE WITH P(SFC)=1013.25 MB C GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL C STRUCTURE WITH P(SFC)=1013.25 MB. C B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN. C CORRECTION FOR T(K). (SEE REF. 4 AND BD3) C B1 = TEMP. COEFFICIENT, USED ALONG WITH B0 C B2 = TEMP. COEFFICIENT, USED ALONG WITH B0 C B3 = TEMP. COEFFICIENT, USED ALONG WITH B0 C COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1), 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L), 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L), 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3 C C***COMMON CO2BD2 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM C CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2. C CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231 C CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238 C C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231 C C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231 C COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1), 1 CDT38(LP1),C2D31(LP1),C2D38(LP1) C C***COMMON CO2BD4 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM C CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4. C CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271 C CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278 C C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271 C C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271 C COMMON / CO2BD4 / CO271(LP1),CO278(LP1),CDT71(LP1), 1 CDT78(LP1),C2D71(LP1),C2D78(LP1) C C***COMMON CO2BD5 CONTAINS CO2 TRANSMISSION FUNCTIONS FOR THE 2270- C 2380 PART OF THE 4.3 UM CO2 BAND. THESE DATA ARE IN BLOCK DATA BD5. C CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C COMMON / CO2BD5 / CO211(LP1),CO218(LP1) C C====> BEGIN HERE TO GET CONSTANTS FOR RADIATION PACKAGE REWIND NFILE C READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.... DO 10 KK=1,2 READ(NFILE) (SGTMP(I,KK),I=1,LP1) 10 CONTINUE DO 15 KK=1,6 READ(NFILE) (CO21D(I,KK),I=1,L) 15 CONTINUE DO 20 KK=1,6 READ(NFILE) ((CO22D(I,J,KK),I=1,LP1),J=1,LP1) 20 CONTINUE DO 25 KK=1,6 READ(NFILE) (CO21D3(I,KK),I=1,LP1) 25 CONTINUE DO 30 KK=1,6 READ(NFILE) (CO21D7(I,KK),I=1,LP1) 30 CONTINUE C READ CO2 CONCENTRATION IN PPM (DEFAULTED IN GRADFS IF MISSING) READ(NFILE,END=31) RCO2 31 CONTINUE PRINT *,'CO2 CONCENTRATION IS ',RCO2 REWIND NFILE DO 35 K=1,LP1 STEMP(K) = SGTMP(K,1) GTEMP(K) = SGTMP(K,2) 35 CONTINUE DO 40 K=1,L CDTM51(K) = CO21D(K,1) CO2M51(K) = CO21D(K,2) C2DM51(K) = CO21D(K,3) CDTM58(K) = CO21D(K,4) CO2M58(K) = CO21D(K,5) C2DM58(K) = CO21D(K,6) 40 CONTINUE DO 45 J=1,LP1 DO 45 I=1,LP1 CDT51(I,J) = CO22D(I,J,1) CO251(I,J) = CO22D(I,J,2) C2D51(I,J) = CO22D(I,J,3) CDT58(I,J) = CO22D(I,J,4) CO258(I,J) = CO22D(I,J,5) C2D58(I,J) = CO22D(I,J,6) 45 CONTINUE DO 50 K=1,LP1 CDT31(K) = CO21D3(K,1) CO231(K) = CO21D3(K,2) C2D31(K) = CO21D3(K,3) CDT38(K) = CO21D3(K,4) CO238(K) = CO21D3(K,5) C2D38(K) = CO21D3(K,6) 50 CONTINUE DO 55 K=1,LP1 CDT71(K) = CO21D7(K,1) CO271(K) = CO21D7(K,2) C2D71(K) = CO21D7(K,3) CDT78(K) = CO21D7(K,4) CO278(K) = CO21D7(K,5) C2D78(K) = CO21D7(K,6) 55 CONTINUE PRINT 66,NFILE 66 FORMAT(1H ,'----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2) C C...... DEFINE TABLES FOR LW RADIATION CALL TABLE C RETURN END SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, 1 AVEPHI,TEMP,T) CFPP$ NOCONCUR R C C SUBROUTINE E1E290 COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION C FOR LONGWAVE RADIATION FOR ALL TERMS EXCEPT THE EXCHANGE WITH THE C TOP OF THE ATMOSPHERE. THE METHOD IS A TABLE LOOKUP ON A PRE- C COMPUTED E2 FUNCTION (DEFINED IN REF. (4)). C THE E1 FUNCTION CALCULATIONS (FORMERLY DONE IN SUBROUTINE C E1V88 COMPUTE THE FLUX RESULTING FROM THE EXCHANGE OF PHOTONS C BETWEEN A LAYER AND THE TOP OF THE ATMOSPHERE. THE METHOD IS A C TABLE LOOKUP ON A PRE-COMPUTED E1 FUNCTION. C CALCULATIONS ARE DONE IN TWO FREQUENCY RANGES: C 1) 0-560,1200-2200 CM-1 FOR Q(APPROX) C 2) 160-560 CM-1 FOR Q(APPROX,CTS). C MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4). C INPUTS: (COMMON BLOCKS) C TABLE1,TABLE2,TABLE3,EM1,EM1WDE TABCOM C AVEPHI TFCOM C TEMP RADISW C T KDACOM C FXOE1,DTE1 ARGUMENT LIST C FXOE2,DTE2 ARGUMENT LIST C OUTPUTS: C EMISS TFCOM C G1,G2,G3 ARGUMENT LIST,FOR 1ST FREQ. RANGE C G4,G5 ARGUMENT LIST,FOR 2ND FREQ. RANGE C C CALLED BY : FST88 C CALLS : C C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK TABCOM CONTAINS QUANTITIES PRECOMPUTED IN SUBROUTINE C TABLE FOR USE IN THE LONGWAVE RADIATION PROGRAM: C EM1 = E1 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C EM1WDE = E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1 C INTERVAL C TABLE1 = E2 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C TABLE2 = TEMPERATURE DERIVATIVE OF TABLE1 C TABLE3 = MASS DERIVATIVE OF TABLE1 C EM3 = E3 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C SOURCE = PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR C BANDS USED IN CTS CALCULATIONS C DSRCE = TEMPERATURE DERIVATIVE OF SOURCE C IND = INDEX, WITH VALUE IND(I)=I. USED IN FST88 C INDX2 = INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXV = INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXVM = KMAXV(L),USED FOR DO LOOP INDICES C COMMON / TABCOM / IND(IMAX),INDX2(LP1V),KMAXV(LP1), 1 KMAXVM,IDUMMY2(IMAX+LP1V+LP1+1) COMMON/TABCOM/EM1(28,180),EM1WDE(28,180),TABLE1(28,180), 1 TABLE2(28,180),TABLE3(28,180),EM3(28,180),SOURCE(28,NBLY), 2 DSRCE(28,NBLY) DIMENSION TEMP(IMBX,LP1),T(IMBX,LP1) DIMENSION AVEPHI(IMBX,LP1),EMISS(IMBX,LP1) C DIMENSION IT1(IMBX,LL3P),IVAL(IMBX,LP1), 5 FYO(IMBX,LP1),DU(IMBX,LP1), 6 WW1(IMBX,LP1),WW2(IMBX,LP1), 7 TMP3(IMBX,LP1),TMP5(IMAX),TMP9(IMAX) C---VARIABLES EQUIVALENCED TO COMMON BLOCK VARIABLES DIMENSION T1(5040),T2(5040),T4(5040) DIMENSION EM1V(5040),EM1VW(5040) C---VARIABLES IN THE ARGUMENT LIST DIMENSION FXOE1(IMBX,LP1),DTE1(IMBX,LP1), 1 FXOE2(IMBX,LP1),DTE2(IMBX,LP1), 2 G1(IMBX,LP1),G2(IMBX,L),G3(IMBX,LP1),G4(IMBX,LP1),G5(IMBX,L) C EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), 1 (T4(1),TABLE3(1,1)) C---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE C (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE C THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN C OBTAINED IN FST88, FOR CONVENIENCE. C C---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY-- C C---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS C THE SPECIAL CASE FOR THE LP1TH LAYER. DO 1322 KP=1,LP1 DO 1322 I=1,IMAX TMP3(I,KP)=LOG10(AVEPHI(I,KP))+H16E1 FYO(I,KP)=AINT(TMP3(I,KP)*TEN) DU(I,KP)=TMP3(I,KP)-HP1*FYO(I,KP) FYO(I,KP)=H28E1*FYO(I,KP) IVAL(I,KP)=FYO(I,KP)+FXOE2(I,KP) EMISS(I,KP)=T1(IVAL(I,KP))+DU(I,KP)*T2(IVAL(I,KP)) 1 +DTE2(I,KP)*T4(IVAL(I,KP)) 1322 CONTINUE C C---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW C BY AVERAGING THE VALUES FOR L AND LP1: DO 1344 I=1,IMAX EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1)) 1344 CONTINUE C C CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS C THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE C TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING C TO THE FLUXES AT OTHER LEVELS. C C***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY C DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE C SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE C BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED C IN THE E2 CALCS.,WITH K=1). C C C FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE C USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT C THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE C INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED. DO 208 I=1,IMAX IT1(I,1)=FXOE1(I,1) WW1(I,1)=TEN-DTE1(I,1) WW2(I,1)=HP1 208 CONTINUE DO 209 KP=1,L DO 209 I=1,IMAX IT1(I,KP+1)=FYO(I,KP)+FXOE1(I,KP+1) IT1(I,KP+LP1)=FYO(I,KP)+FXOE1(I,KP) WW1(I,KP+1)=TEN-DTE1(I,KP+1) WW2(I,KP+1)=HP1-DU(I,KP) 209 CONTINUE DO 211 KP=1,L DO 211 I=1,IMAX IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1) 211 CONTINUE C C C G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG) DO 230 I=1,IMAX G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ 1 WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1) G3(I,1)=G1(I,1) 230 CONTINUE DO 240 KP=1,L DO 240 I=1,IMAX G1(I,KP+1)=WW1(I,KP+1)*WW2(I,KP+1)*EM1V(IT1(I,KP+1))+ 1 WW2(I,KP+1)*DTE1(I,KP+1)*EM1V(IT1(I,KP+1)+1)+ 2 WW1(I,KP+1)*DU(I,KP)*EM1V(IT1(I,KP+1)+28)+ 3 DTE1(I,KP+1)*DU(I,KP)*EM1V(IT1(I,KP+1)+29) G2(I,KP)=WW1(I,KP)*WW2(I,KP+1)*EM1V(IT1(I,KP+LP1))+ 1 WW2(I,KP+1)*DTE1(I,KP)*EM1V(IT1(I,KP+LP1)+1)+ 1 WW1(I,KP)*DU(I,KP)*EM1V(IT1(I,KP+LP1)+28)+ 2 DTE1(I,KP)*DU(I,KP)*EM1V(IT1(I,KP+LP1)+29) 240 CONTINUE DO 241 KP=2,LP1 DO 241 I=1,IMAX G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ 1 WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ 2 WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ 3 DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29) 241 CONTINUE C DO 244 I=1,IMAX G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ 1 WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1) 244 CONTINUE DO 242 KP=1,L DO 242 I=1,IMAX G4(I,KP+1)=WW1(I,KP+1)*WW2(I,KP+1)*EM1VW(IT1(I,KP+1))+ 1 WW2(I,KP+1)*DTE1(I,KP+1)*EM1VW(IT1(I,KP+1)+1)+ 2 WW1(I,KP+1)*DU(I,KP)*EM1VW(IT1(I,KP+1)+28)+ 3 DTE1(I,KP+1)*DU(I,KP)*EM1VW(IT1(I,KP+1)+29) G5(I,KP)=WW1(I,KP)*WW2(I,KP+1)*EM1VW(IT1(I,KP+LP1))+ 1 WW2(I,KP+1)*DTE1(I,KP)*EM1VW(IT1(I,KP+LP1)+1)+ 1 WW1(I,KP)*DU(I,KP)*EM1VW(IT1(I,KP+LP1)+28)+ 2 DTE1(I,KP)*DU(I,KP)*EM1VW(IT1(I,KP+LP1)+29) 242 CONTINUE C RETURN END SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2) CFPP$ NOCONCUR R C C SUBROUTINE E290 COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION C FOR LONGWAVE RADIATION FOR ALL TERMS EXCEPT THE EXCHANGE WITH THE C TOP OF THE ATMOSPHERE. THE METHOD IS A TABLE LOOKUP ON A PRE- C COMPUTED E2 FUNCTION (DEFINED IN REF. (4)). C CALCULATIONS ARE DONE IN THE FREQUENCY RANGE: C 1) 0-560,1200-2200 CM-1 FOR Q(APPROX) C MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4). C INPUTS: (COMMON BLOCKS) C TABLE1,TABLE2,TABLE3, TABCOM C AVEPHI TFCOM C FXOE2,DTE2,KLEN ARGUMENT LIST C OUTPUTS: C EMISS,EMISSB TFCOM C C CALLED BY : FST88 C CALLS : C C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK TABCOM CONTAINS QUANTITIES PRECOMPUTED IN SUBROUTINE C TABLE FOR USE IN THE LONGWAVE RADIATION PROGRAM: C EM1 = E1 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C EM1WDE = E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1 C INTERVAL C TABLE1 = E2 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C TABLE2 = TEMPERATURE DERIVATIVE OF TABLE1 C TABLE3 = MASS DERIVATIVE OF TABLE1 C EM3 = E3 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C SOURCE = PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR C BANDS USED IN CTS CALCULATIONS C DSRCE = TEMPERATURE DERIVATIVE OF SOURCE C IND = INDEX, WITH VALUE IND(I)=I. USED IN FST88 C INDX2 = INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXV = INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXVM = KMAXV(L),USED FOR DO LOOP INDICES C COMMON / TABCOM / IND(IMAX),INDX2(LP1V),KMAXV(LP1), 1 KMAXVM,IDUMMY2(IMAX+LP1V+LP1+1) COMMON/TABCOM/EM1(28,180),EM1WDE(28,180),TABLE1(28,180), 1 TABLE2(28,180),TABLE3(28,180),EM3(28,180),SOURCE(28,NBLY), 2 DSRCE(28,NBLY) DIMENSION EMISSB(IMBX,LP1),EMISS(IMBX,LP1),AVEPHI(IMBX,LP1) DIMENSION IVAL(IMBX,LP1), 1 DT(IMBX,LP1),FYO(IMBX,LP1),DU(IMBX,LP1) C---TMP3 MAY BE EQUIVALENCED TO DT IN VTEMP DIMENSION TMP3(IMBX,LP1) C---VARIABLES EQUIVALENCED TO COMMON BLOCK VARIABLES DIMENSION T1(5040),T2(5040),T4(5040) C---VARIABLES IN THE ARGUMENT LIST DIMENSION FXOE2(IMBX,LP1),DTE2(IMBX,LP1) C EQUIVALENCE (TMP3,DT) EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), 1 (T4(1),TABLE3(1,1)) C---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE C (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE C THUS GENERATES THE E2 FUNCTION. C C---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL C CASE: RESULTS ARE IN EMISS DO 132 K=1,LP2-KLEN DO 132 I=1,IMAX TMP3(I,K)=LOG10(AVEPHI(I,K+KLEN-1))+H16E1 FYO(I,K)=AINT(TMP3(I,K)*TEN) DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) FYO(I,K)=H28E1*FYO(I,K) IVAL(I,K)=FYO(I,K)+FXOE2(I,K+KLEN-1) EMISS(I,K+KLEN-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) 1 +DTE2(I,K+KLEN-1)*T4(IVAL(I,K)) 132 CONTINUE C---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW C BY AVERAGING THE VALUES FOR L AND LP1: DO 1344 I=1,IMAX EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1)) 1344 CONTINUE C---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT. C C---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB. C IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING C FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH C THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT C INVOLVED HERE. C (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN C EMISSB(I,(KLEN) TO L) DO 142 K=1,LP1-KLEN DO 142 I=1,IMAX DT(I,K)=DTE2(I,KLEN-1) IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1) 142 CONTINUE C DO 234 K=1,LP1-KLEN DO 234 I=1,IMAX EMISSB(I,K+KLEN-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) 1 +DT(I,K)*T4(IVAL(I,K)) 234 CONTINUE RETURN END SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP) CFPP$ NOCONCUR R C C SUBROUTINE E2SPEC COMPUTES THE EXCHANGE TERMS IN THE FLUX EQUATION C FOR LONGWAVE RADIATION FOR 2 TERMS USED FOR NEARBY LAYER COMPU- C TATIONS. THE METHOD IS A TABLE LOOKUP ON A PRE- C COMPUTED E2 FUNCTION (DEFINED IN REF. (4)). C CALCULATIONS ARE DONE IN THE FREQUENCY RANGE: C 0-560,1200-2200 CM-1 C MOTIVATION FOR THESE CALCULATIONS IS IN REFERENCES (1) AND (4). C INPUTS: (COMMON BLOCKS) C TABLE1,TABLE2,TABLE3, TABCOM C AVEPHI TFCOM C FXOSP,DTSP ARGUMENT LIST C OUTPUTS: C EMISS TFCOM C C CALLED BY : FST88 C CALLS : C C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK TABCOM CONTAINS QUANTITIES PRECOMPUTED IN SUBROUTINE C TABLE FOR USE IN THE LONGWAVE RADIATION PROGRAM: C EM1 = E1 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C EM1WDE = E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1 C INTERVAL C TABLE1 = E2 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C TABLE2 = TEMPERATURE DERIVATIVE OF TABLE1 C TABLE3 = MASS DERIVATIVE OF TABLE1 C EM3 = E3 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C SOURCE = PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR C BANDS USED IN CTS CALCULATIONS C DSRCE = TEMPERATURE DERIVATIVE OF SOURCE C IND = INDEX, WITH VALUE IND(I)=I. USED IN FST88 C INDX2 = INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXV = INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXVM = KMAXV(L),USED FOR DO LOOP INDICES C COMMON / TABCOM / IND(IMAX),INDX2(LP1V),KMAXV(LP1), 1 KMAXVM,IDUMMY2(IMAX+LP1V+LP1+1) COMMON/TABCOM/EM1(28,180),EM1WDE(28,180),TABLE1(28,180), 1 TABLE2(28,180),TABLE3(28,180),EM3(28,180),SOURCE(28,NBLY), 2 DSRCE(28,NBLY) DIMENSION AVEPHI(IMBX,LP1),EMISS(IMBX,LP1) DIMENSION IVAL(IMBX,LP1), 1 FYO(IMBX,LP1),DU(IMBX,LP1), 2 TMP3(IMBX,LP1) C---VARIABLES EQUIVALENCED TO COMMON BLOCK VARIABLES DIMENSION T1(5040),T2(5040),T4(5040) C---VARIABLES IN THE ARGUMENT LIST DIMENSION FXOSP(IMBX,2),DTSP(IMBX,2) C EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), 1 (T4(1),TABLE3(1,1)) C---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE C (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE C THUS GENERATES THE E2 FUNCTION. C DO 132 K=1,2 DO 132 I=1,IMAX TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1 FYO(I,K)=AINT(TMP3(I,K)*TEN) DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K) EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ 1 DTSP(I,K)*T4(IVAL(I,K)) 132 CONTINUE RETURN END C SUBROUTINE E3V88 COMPUTES NEARBY LAYER TRANSMISSIVITIES FOR C H2O USING A TABLE LOOKUP OF THE PRE-COMPUTED E3 FUNCTION C ( DESCRIBED IN REF. (4)). C INPUTS: (COMMON BLOCKS,ARGS.) C TV,AV ARGUMENT LIST C EM3 TABCOM C OUTPUTS: C EMV ARGUMENT LIST C C CALLED BY : FST88 C CALLS : ALOG10H,ALOG10V C SUBROUTINE E3V88(EMV,TV,AV) CFPP$ NOCONCUR R C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK TABCOM CONTAINS QUANTITIES PRECOMPUTED IN SUBROUTINE C TABLE FOR USE IN THE LONGWAVE RADIATION PROGRAM: C EM1 = E1 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C EM1WDE = E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1 C INTERVAL C TABLE1 = E2 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C TABLE2 = TEMPERATURE DERIVATIVE OF TABLE1 C TABLE3 = MASS DERIVATIVE OF TABLE1 C EM3 = E3 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C SOURCE = PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR C BANDS USED IN CTS CALCULATIONS C DSRCE = TEMPERATURE DERIVATIVE OF SOURCE C IND = INDEX, WITH VALUE IND(I)=I. USED IN FST88 C INDX2 = INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXV = INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXVM = KMAXV(L),USED FOR DO LOOP INDICES C COMMON / TABCOM / IND(IMAX),INDX2(LP1V),KMAXV(LP1), 1 KMAXVM,IDUMMY2(IMAX+LP1V+LP1+1) COMMON/TABCOM/EM1(28,180),EM1WDE(28,180),TABLE1(28,180), 1 TABLE2(28,180),TABLE3(28,180),EM3(28,180),SOURCE(28,NBLY), 2 DSRCE(28,NBLY) DIMENSION IT(IMBX,LLP1),WW1(IMBX,LLP1), 1 DT(IMBX,LLP1),WW2(IMBX,LLP1), 2 DU(IMBX,LLP1) C THE FOLLOWING ARRAYS ARE EQUIVALENCED TO VTEMP ARRAYS DIMENSION FXO(IMBX,LLP1),FYO(IMBX,LLP1),TMP3(IMBX,LLP1) C C DIMENSIONS OF ARRAYS IN ARGUMENT LIST DIMENSION EMV(IMBX,LLP1),TV(IMBX,LLP1),AV(IMBX,LLP1) C C THE FOLLOWING ARRAY IS EQUIVALENCED TO AN ARRAY IN TABCOM.H DIMENSION EM3V(5040) C EQUIVALENCE (EM3V(1),EM3(1,1)) EQUIVALENCE (FXO,WW1),(FYO,WW2),(IT,TMP3) C---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND C K (1-LLP1) DO 203 K=1,LLP1 DO 203 I=1,IMAX FXO(I,K)=AINT(TV(I,K)*HP1) TMP3(I,K)=LOG10(AV(I,K))+H16E1 DT(I,K)=TV(I,K)-TEN*FXO(I,K) FYO(I,K)=AINT(TMP3(I,K)*TEN) DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) C---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE C DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K. IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1 WW1(I,K)=TEN-DT(I,K) WW2(I,K)=HP1-DU(I,K) EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ 1 WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ 2 WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ 3 DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20) 203 CONTINUE RETURN END C ***************************************************************** C SUBROUTINE FST88 IS THE MAIN COMPUTATION MODULE OF THE C LONG-WAVE RADIATION CODE. IN IT ALL "EMISSIVITY" CALCULATIONS, C INCLUDING CALLS TO TABLE LOOKUP SUBROUTINES. ALSO,AFTER CALLING C SUBROUTINE "SPA88", FINAL COMBINED HEATING RATES AND GROUND C FLUX ARE OBTAINED. C ***************************************************************** C INPUTS: C BETINW,BETAWD,AB15WD BDWIDE C BETAD,BO3RND,AO3RND BANDTA C CLDFAC CLDCOM C QH2O,P,DELP2,DELP,T,VAR1,VAR2, KDACOM C VAR3,VAR4,CNTVAL KDACOM C TOTVO2,TOTO3,TOTPHI,EMPL,EMX1 KDACOM C TPHIO3,EMX2 KDACOM C TEMP,PRESS RADISW C NCLDS,KTOP,KBTM,CAMT RADISW C IND,INDX2,KMAXV,SOURCE,DSRCE TABCOM C SKC1R,SKC3R,KMAXVM,NREP1,NREP2 TABCOM C NST1,NST2,NRP1,NRP2 TABCOM C CO2NBL,CO21 TFCOM C CO2SP1,CO2SP2 TFCOM C OUTPUTS: C HEATRA,GRNFLX,TOPFLX LWOUT C C CALLED BY : RADMN OR MAIN PGM C CALLS : CLO88,E1E288,E3V88,SPA88,NLTE C C PASSED VARIABLES: C IN E3V88: C EMD = E3 FUNCTION FOR H2O LINES (0-560,1200-2200 CM-1) C COMPUTED IN E3V88 C TPL = TEMPERATURE INPUT FOR E3 CALCULATION IN E3V88 C EMPL = H2O AMOUNT,INPUT FOR E3 CALCULATION IN E3V88 C (COMPUTED IN LWR88; STORED IN KDACOM.H) C IN E1E288: C E1CTS1 = E1 FUNCTION FOR THE (I+1)TH LEVEL USING THE C TEMPERATURE OF THE ITH DATA LEVEL,COMPUTED OVER C THE FREQUENCY RANGE 0-560,1200-2200 CM-1. (E1CTS1- C E1CTW1) IS USED IN OBTAINING THE FLUX AT THE TOP C IN THE 0-160,1200-2200 CM-1 RANGE (FLX1E1). C E1CTS2 = E1 FUNCTION FOR THE ITH LEVEL, USING THE TEMP. OF C THE ITH DATA LEVEL,COMPUTED OVER THE FREQUENCY RANGE C 0-560,1200-2200 CM-1. (E1CTS2-E1CTW2) IS ALSO USED C IN OBTAINING THE FLUX AT THE TOP IN THE 0-160,. C 1200-2200 CM-1 RANGE. C E1FLX = E1 FCTN. FOR THE ITH LEVEL,USING THE TEMPERATURE AT C THE TOP OF THE ATMOSPHERE. COMPUTED OVER THE FREQ. C RANGE 0-560,1200-2200 CM-1. USED FOR Q(APPROX) TERM. C (IN COMMON BLOCK TFCOM) C E1CTW1 = LIKE E1CTS1,BUT COMPUTED OVER THE 160-560 CM-1 RANGE C AND USED FOR Q(APPROX,CTS) CALCULATION C E1CTW2 = LIKE E1CTS2,BUT COMPUTED OVER THE 160-560 CM-1 RANGE C AND USED FOR Q(APPROX,CTS) CALCULATION C FXO = TEMPERATURE INDEX USED FOR E1 FUNCTION AND ALSO C USED FOR SOURCE FUNCTION CALC. IN FST88. C DT = TEMP. DIFF.BETWEEN MODEL TEMPS. AND TEMPS. AT C TABULAR VALUES OF E1 AND SOURCE FCTNS. USED IN C FST88 AND IN E1 FUNCTION CALC. C FXOE2 = TEMPERATURE INDEX USED FOR E2 FUNCTION C DTE2 = TEMP. DIFF. BETWEEN MODEL TEMP. AND TEMPS. AT C TABULAR VALUES OF E2 FUNCTION. SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, 1 GRNFX0,TOPFX0, 1 QH2O,PRESS,P,DELP,DELP2,TEMP,T, 2 CLDFAC,NCLDS,KTOP,KBTM,CAMT, 3 CO21,CO2NBL,CO2SP1,CO2SP2, 4 VAR1,VAR2,VAR3,VAR4,CNTVAL, 5 TOTO3,TPHIO3,TOTPHI,TOTVO2, 6 EMX1,EMX2,EMPL) CFPP$ NOCONCUR R C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK BANDTA CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING 10 CM-1 WIDE BANDS.THE 15 UM CO2 COMPLEX C IS 2 BANDS,560-670 AND 670-800 CM-1. OZONE COEFFICIENTS ARE C IN 3 BANDS,670-800 (14.1 UM),990-1070 AND 1070-1200 (9.6 UM). C THE (NBLW) BANDS NOW INCLUDE: C 56 BANDS, 10 CM-1 WIDE 0 - 560 CM-1 C 2 BANDS, 15 UM COMPLEX 560 - 670 CM-1 C 670 - 800 CM-1 C 3 "CONTINUUM" BANDS 800 - 900 CM-1 C 900 - 990 CM-1 C 1070 - 1200 CM-1 C 1 BAND FOR 9.6 UM BAND 990 - 1070 CM-1 C 100 BANDS, 10 CM-1 WIDE 1200 - 2200 CM-1 C 1 BAND FOR 4.3 UM SRC 2270 - 2380 CM-1 C THUS NBLW PRESENTLY EQUALS 163 C ALL BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C C ARNDM = RANDOM "A" PARAMETER FOR (NBLW) BANDS C BRNDM = RANDOM "B" PARAMETER FOR (NBLW) BANDS C BETAD = CONTINUUM COEFFICIENTS FOR (NBLW) BANDS C AP,BP = CAPPHI COEFFICIENTS FOR (NBLW) BANDS C ATP,BTP = CAPPSI COEFFICIENTS FOR (NBLW) BANDS C BANDLO = LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C BANDHI = HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C AO3RND = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3RND = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15 = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C DATA FOR ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND ARE OBTAINED BY C USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS ARE FROM C ROBERTS (1976). COMMON / BANDTA / ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW), 1 BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW), 2 BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2) C C COMMON BLOCK BDWIDE CONTAINS RANDOM BAND PARAMETERS FOR SPECIFIC C WIDE BANDS. AT PRESENT,THE INFORMATION CONSISTS OF 1) RANDOM C MODEL PARAMETERS FOR THE 15 UM BAND,560-800 CM-1; 2) THE C CONTINUUM COEFFICIENT FOR THE 800-990,1070-1200 CM-1 BAND C SPECIFICALLY: C AWIDE = RANDOM "A" PARAMETER FOR BAND C BWIDE = RANDOM "B" PARAMETER FOR BAND C BETAWD = CONTINUUM COEFFICIENTS FOR BAND C APWD,BPWD = CAPPHI COEFFICIENTS FOR BAND C ATPWD,BTPWD = CAPPSI COEFFICIENTS FOR BAND C BDLOWD = LOWEST FREQUENCY IN EACH FREQ BAND C BDHIWD = HIGHEST FREQUENCY IN EACH FREQ BAND C AB15WD = THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINW = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C SKO2D = 1./BETINW, USED IN SPA88 FOR CONT. COEFFS C SKC1R = BETAWD/BETINW, USED FOR CONT. COEFF. FOR C 15 UM BAND IN FST88 C SKO3R = RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO C BETINW, USED FOR 9.6 UM CONT COEFF IN FST88 C DATA FOR AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). COMMON / BDWIDE / AWIDE,BWIDE,BETAWD, 1 APWD,BPWD,ATPWD,BTPWD, 2 BDLOWD,BDHIWD,BETINW, 3 AB15WD,SKO2D,SKC1R,SKO3R C C COMMON BLOCK BDCOMB CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING COMBINED WIDE FREQUENCY BANDS BETWEEN 160 AND C 1200 CM-1,AS WELL AS THE 2270-2380 BAND FOR SOURCE CALC. C BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1 C BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS) C FOR 560-1200 CM-1 C BAND 15: FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE C CALCULATION ONLY C THUS NBLY PRESENTLY EQUALS 15 C C BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C ACOMB = RANDOM "A" PARAMETER FOR (NBLY) BANDS C BCOMB = RANDOM "B" PARAMETER FOR (NBLY) BANDS C BETACM = CONTINUUM COEFFICIENTS FOR (NBLY) BANDS C APCM,BPCM = CAPPHI COEFFICIENTS FOR (NBLY) BANDS C ATPCM,BTPCM = CAPPSI COEFFICIENTS FOR (NBLY) BANDS C BDLOCM = LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C BDHICM = HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C AO3CM = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3CM = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15CM = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINC = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C IBAND = INDEX NO OF THE 40 WIDE BANDS USED IN C COMBINED WIDE BAND CALCULATIONS. IN OTHER C WORDS,INDEX TELLING WHICH OF THE 40 WIDE C BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN C EACH OF THE FIRST 8 COMBINED WIDE BANDS C DATA FOR ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). IBAND INDEX VALUES ARE OBTAINED BY C EXPERIMENTATION. COMMON / BDCOMB / IBAND(40),ACOMB(NBLY),BCOMB(NBLY), 1 BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), 2 BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC, 3 AO3CM(3),BO3CM(3),AB15CM(2) C C COMMON BLOCK TABCOM CONTAINS QUANTITIES PRECOMPUTED IN SUBROUTINE C TABLE FOR USE IN THE LONGWAVE RADIATION PROGRAM: C EM1 = E1 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C EM1WDE = E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1 C INTERVAL C TABLE1 = E2 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C TABLE2 = TEMPERATURE DERIVATIVE OF TABLE1 C TABLE3 = MASS DERIVATIVE OF TABLE1 C EM3 = E3 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C SOURCE = PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR C BANDS USED IN CTS CALCULATIONS C DSRCE = TEMPERATURE DERIVATIVE OF SOURCE C IND = INDEX, WITH VALUE IND(I)=I. USED IN FST88 C INDX2 = INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXV = INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXVM = KMAXV(L),USED FOR DO LOOP INDICES C COMMON / TABCOM / IND(IMAX),INDX2(LP1V),KMAXV(LP1), 1 KMAXVM,IDUMMY2(IMAX+LP1V+LP1+1) COMMON/TABCOM/EM1(28,180),EM1WDE(28,180),TABLE1(28,180), 1 TABLE2(28,180),TABLE3(28,180),EM3(28,180),SOURCE(28,NBLY), 2 DSRCE(28,NBLY) C DIMENSION QH2O(IMBX,LP1),PRESS(IMBX,LP1) DIMENSION P(IMBX,LP1),DELP(IMBX,L),DELP2(IMBX,L),TEMP(IMBX,LP1) DIMENSION T(IMBX,LP1),CLDFAC(IMBX,LP1,LP1),CAMT(IMBX,LP1) DIMENSION NCLDS(IMAX),KTOP(IMBX,LP1),KBTM(IMBX,LP1) DIMENSION CO21(IMBX,LP1,LP1),CO2NBL(IMBX,L) DIMENSION CO2SP1(IMBX,LP1),CO2SP2(IMBX,LP1) DIMENSION VAR1(IMBX,L),VAR2(IMBX,L),VAR3(IMBX,L),VAR4(IMBX,L) DIMENSION CNTVAL(IMBX,LP1) DIMENSION HEATRA(IMBX,L),GRNFLX(IMAX),TOPFLX(IMAX) C DIMENSION HEATR0(IMBX,L),FLXNT0(IMBX,LP1) DIMENSION GRNFX0(IMAX),TOPFX0(IMAX),GXCTS0(IMAX),FLX1E0(IMAX) DIMENSION EXCTS0(IMBX,L),CTSO30(IMBX,L),CTS0(IMBX,L) DIMENSION FLX0(IMBX,LP1) C DIMENSION GXCTS(IMAX),FLX1E1(IMAX) DIMENSION AVEPHI(IMBX,LP1),EMISS(IMBX,LP1),EMISSB(IMBX,LP1) C DIMENSION TOTO3(IMBX,LP1),TPHIO3(IMBX,LP1),TOTPHI(IMBX,LP1) DIMENSION TOTVO2(IMBX,LP1),EMX1(IMAX),EMX2(IMAX),EMPL(IMBX,LLP1) C DIMENSION EXCTS(IMBX,L),CTSO3(IMBX,L),CTS(IMBX,L),E1FLX(IMBX,LP1) DIMENSION CO2SP(IMBX,LP1),TO3SPC(IMBX,L),TO3SP(IMBX,LP1) DIMENSION OSS(IMBX,LP1),CSS(IMBX,LP1),SS1(IMBX,LP1),SS2(IMBX,LP1), 1 TC(IMBX,LP1),DTC(IMBX,LP1) DIMENSION SORC(IMBX,LP1,NBLY),CSOUR(IMBX,LP1) CCC DIMENSION AVVO2(IMBX,LP1),HEATEM(IMBX,LP1), 1 OVER1D(IMBX,LP1), 1 TO31D(IMBX,LP1),CONT1D(IMBX,LP1), 2 AVMO3(IMBX,LP1),AVPHO3(IMBX,LP1), 2 C(IMBX,LLP1),C2(IMBX,LLP1) DIMENSION ITOP(IMAX),IBOT(IMAX),INDTC(IMAX) DIMENSION 4 DELPTC(IMAX),PTOP(IMAX),PBOT(IMAX),FTOP(IMAX), 5 FBOT(IMAX) ,EMSPEC(IMBX,2) C---DIMENSION OF VARIABLES EQUIVALENCED TO THOSE IN VTEMP--- DIMENSION VTMP3(IMBX,LP1),DSORC(IMBX,LP1) DIMENSION ALP(IMBX,LLP1),CSUB(IMBX,LLP1),CSUB2(IMBX,LLP1) DIMENSION FAC1(IMBX,LP1) DIMENSION DELPR1(IMBX,LP1),DELPR2(IMBX,LP1) DIMENSION EMISDG(IMBX,LP1),CONTDG(IMBX,LP1),TO3DG(IMBX,LP1) DIMENSION FLXNET(IMBX,LP1) DIMENSION IXO(IMBX,LP1) DIMENSION VSUM1(IMBX,LP1) DIMENSION FLXTHK(IMBX,LP1) DIMENSION Z1(IMBX,LP1) C---DIMENSION OF VARIABLES PASSED TO OTHER SUBROUTINES--- C (AND NOT FOUND IN COMMON BLOCKS) DIMENSION E1CTS1(IMBX,LP1),E1CTS2(IMBX,L) DIMENSION E1CTW1(IMBX,LP1),E1CTW2(IMBX,L) DIMENSION EMD(IMBX,LLP1),TPL(IMBX,LLP1) C IT IS POSSIBLE TO EQUIVALENCE EMD,TPL TO THE ABOVE VARIABLES, C AS THEY GET CALLED AT DIFFERENT TIMES DIMENSION FXO(IMBX,LP1),DT(IMBX,LP1) DIMENSION FXOE2(IMBX,LP1),DTE2(IMBX,LP1) DIMENSION FXOSP(IMBX,2),DTSP(IMBX,2) C C DIMENSION OF LOCAL VARIABLES DIMENSION RLOG(IMBX,L),FLX(IMBX,LP1) DIMENSION TOTEVV(IMBX,LP1),CNTTAU(IMBX,LP1) C EQUIVALENCE (ALP,C,CSUB),(CSUB2,C2) EQUIVALENCE (FAC1,DSORC,OVER1D,DELPR2,FLXNET) EQUIVALENCE (DELPR1,HEATEM) EQUIVALENCE (IXO,AVVO2,FLXTHK,TO3DG) EQUIVALENCE (Z1,AVMO3,CONTDG) EQUIVALENCE (EMISDG,VSUM1,AVPHO3) EQUIVALENCE (EMD(1,1),E1CTS1(1,1)),(EMD(1,LP2),E1CTS2(1,1)) EQUIVALENCE (TPL(1,1),E1CTW1(1,1)),(TPL(1,LP2),E1CTW2(1,1)) C C FIRST SECTION IS TABLE LOOKUP FOR SOURCE FUNCTION AND C DERIVATIVE (B AND DB/DT).ALSO,THE NLTE CO2 SOURCE FUNCTION C IS OBTAINED C C---IN CALCS. BELOW, DECREMENTING THE INDEX BY 9 C ACCOUNTS FOR THE TABLES BEGINNING AT T=100K. C AT T=100K. DO 101 K=1,LP1 DO 101 I=1,IMAX C---TEMP. INDICES FOR E1,SOURCE VTMP3(I,K)=AINT(TEMP(I,K)*HP1) FXO(I,K)=VTMP3(I,K)-9. DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K) C---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY) IXO(I,K)=FXO(I,K) 101 CONTINUE DO 103 K=1,L DO 103 I=1,IMAX C---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS) VTMP3(I,K)=AINT(T(I,K+1)*HP1) FXOE2(I,K)=VTMP3(I,K)-9. DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K) 103 CONTINUE C---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS. DO 105 I=1,IMAX FXOE2(I,LP1)=FXO(I,L) DTE2(I,LP1)=DT(I,L) FXOSP(I,1)=FXOE2(I,LM1) FXOSP(I,2)=FXO(I,LM1) DTSP(I,1)=DTE2(I,LM1) DTSP(I,2)=DT(I,LM1) 105 CONTINUE C C---SOURCE FUNCTION FOR COMBINED BAND 1 DO 4114 I=1,IMAX DO 4114 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),1) DSORC(I,K)=DSRCE(IXO(I,K),1) 4114 CONTINUE DO 4112 K=1,LP1 DO 4112 I=1,IMAX SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4112 CONTINUE C---SOURCE FUNCTION FOR COMBINED BAND 2 DO 4214 I=1,IMAX DO 4214 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),2) DSORC(I,K)=DSRCE(IXO(I,K),2) 4214 CONTINUE DO 4212 K=1,LP1 DO 4212 I=1,IMAX SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4212 CONTINUE C---SOURCE FUNCTION FOR COMBINED BAND 3 DO 4314 I=1,IMAX DO 4314 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),3) DSORC(I,K)=DSRCE(IXO(I,K),3) 4314 CONTINUE DO 4312 K=1,LP1 DO 4312 I=1,IMAX SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4312 CONTINUE C---SOURCE FUNCTION FOR COMBINED BAND 4 DO 4414 I=1,IMAX DO 4414 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),4) DSORC(I,K)=DSRCE(IXO(I,K),4) 4414 CONTINUE DO 4412 K=1,LP1 DO 4412 I=1,IMAX SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4412 CONTINUE C---SOURCE FUNCTION FOR COMBINED BAND 5 DO 4514 I=1,IMAX DO 4514 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),5) DSORC(I,K)=DSRCE(IXO(I,K),5) 4514 CONTINUE DO 4512 K=1,LP1 DO 4512 I=1,IMAX SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4512 CONTINUE C---SOURCE FUNCTION FOR COMBINED BAND 6 DO 4614 I=1,IMAX DO 4614 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),6) DSORC(I,K)=DSRCE(IXO(I,K),6) 4614 CONTINUE DO 4612 K=1,LP1 DO 4612 I=1,IMAX SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4612 CONTINUE C---SOURCE FUNCTION FOR COMBINED BAND 7 DO 4714 I=1,IMAX DO 4714 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),7) DSORC(I,K)=DSRCE(IXO(I,K),7) 4714 CONTINUE DO 4712 K=1,LP1 DO 4712 I=1,IMAX SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4712 CONTINUE C---SOURCE FUNCTION FOR COMBINED BAND 8 DO 4814 I=1,IMAX DO 4814 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),8) DSORC(I,K)=DSRCE(IXO(I,K),8) 4814 CONTINUE DO 4812 K=1,LP1 DO 4812 I=1,IMAX SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4812 CONTINUE C---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1) DO 4914 I=1,IMAX DO 4914 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),9) DSORC(I,K)=DSRCE(IXO(I,K),9) 4914 CONTINUE DO 4912 K=1,LP1 DO 4912 I=1,IMAX SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4912 CONTINUE C---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1) DO 5014 I=1,IMAX DO 5014 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),10) DSORC(I,K)=DSRCE(IXO(I,K),10) 5014 CONTINUE DO 5012 K=1,LP1 DO 5012 I=1,IMAX SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5012 CONTINUE C---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1) DO 5114 I=1,IMAX DO 5114 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),11) DSORC(I,K)=DSRCE(IXO(I,K),11) 5114 CONTINUE DO 5112 K=1,LP1 DO 5112 I=1,IMAX SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5112 CONTINUE C---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1) DO 5214 I=1,IMAX DO 5214 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),12) DSORC(I,K)=DSRCE(IXO(I,K),12) 5214 CONTINUE DO 5212 K=1,LP1 DO 5212 I=1,IMAX SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5212 CONTINUE C---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1) DO 5314 I=1,IMAX DO 5314 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),13) DSORC(I,K)=DSRCE(IXO(I,K),13) 5314 CONTINUE DO 5312 K=1,LP1 DO 5312 I=1,IMAX SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5312 CONTINUE C---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1) DO 5414 I=1,IMAX DO 5414 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),14) DSORC(I,K)=DSRCE(IXO(I,K),14) 5414 CONTINUE DO 5412 K=1,LP1 DO 5412 I=1,IMAX SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5412 CONTINUE C C THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2 C C C CALL NLTE C C C---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR) C AND THE WINDOW REGION (SS1) DO 131 K=1,LP1 DO 131 I=1,IMAX SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14) 131 CONTINUE DO 143 K=1,LP1 DO 143 I=1,IMAX CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10) 143 CONTINUE C C---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES C (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA- C TIONS. C DO 901 K=1,LP1 DO 901 I=1,IMAX TC(I,K)=(TEMP(I,K)*TEMP(I,K))**2 901 CONTINUE DO 903 K=1,L DO 903 I=1,IMAX OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13) CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K) DTC(I,K+1)=TC(I,K+1)-TC(I,K) SS2(I,K+1)=SS1(I,K+1)-SS1(I,K) 903 CONTINUE C C C---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO C (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS C ON THE FOLLOWING PRINCIPLES: C C LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL C THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) C OVER ALL KP'S, FROM 1 TO LP1. C C WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS: C C FOR ALL K'S K=1 TO LP1: C FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) (1) C OVER ALL KP'S, FROM K+1 TO LP1 C AND C FOR KP FROM K+1 TO LP1: C FLUX(KP) = DELTAB(K)*TAU(K,KP) (2) C C NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS) C WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM C K+1 TO LP1, EACH TIME K IS INCREMENTED. C EQUATIONS (1) AND (2) THEN BECOME: C C TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K) C FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP)) (3) C FLUX(KP) = DELTAB(K)*TAU1D(KP) (4) C C THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR C NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND C WITH CARE. C C COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR C THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO, C THE C STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI C---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY C AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY C MAY BE EXTRACTED HERE. DO 3021 K=1,L DO 3021 I=1,IMAX AVEPHI(I,K)=TOTPHI(I,K+1) 3021 CONTINUE C---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1) C LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES C A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE C (OTHERWISE VACANT) LP1'TH POSITION C DO 803 I=1,IMAX AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I) 803 CONTINUE C COMPUTE FLUXES FOR K=1 CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, 1 FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T) DO 302 K=1,L DO 302 I=1,IMAX FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1) TO3SPC(I,K)=HAF*(FAC1(I,K)* 1 (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE)) C FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS C CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY. TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1))) OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ 1 SKC1R*TOTVO2(I,K+1))) C---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE C 2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH C OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1)) TOTEVV(I,K)=1./CNTTAU(I,K) 302 CONTINUE DO 3022 K=1,L DO 3022 I=1,IMAX CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1) 3022 CONTINUE DO 3023 K=1,L DO 3023 I=1,IMAX CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K) 3023 CONTINUE C---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION DO 1808 I=1,IMAX RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1) 1808 CONTINUE C---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH C THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN C THE OTHER CALCULATIONS DO 305 K=2,LP1 DO 305 I=1,IMAX FLX(I,K)= (TC(I,1)*E1FLX(I,K) 1 +SS1(I,1)*CNTTAU(I,K-1) 2 +SORC(I,1,13)*TO3SP(I,K-1) 3 +CSOUR(I,1)*CO2SP(I,K)) 4 *CLDFAC(I,1,K) 305 CONTINUE DO 307 I=1,IMAX FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) 1 +CSOUR(I,1) 307 CONTINUE C---THE KP TERMS FOR K=1... DO 303 KP=2,LP1 DO 303 I=1,IMAX FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) 1 +SS2(I,KP)*CNTTAU(I,KP-1) 2 +CSS(I,KP)*CO21(I,KP,1) 3 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1) 303 CONTINUE C... DITTO FOR CLEAR SKY.... DO 2305 K=2,LP1 DO 2305 I=1,IMAX FLX0(I,K)= TC(I,1)*E1FLX(I,K) 1 +SS1(I,1)*CNTTAU(I,K-1) 2 +SORC(I,1,13)*TO3SP(I,K-1) 3 +CSOUR(I,1)*CO2SP(I,K) 2305 CONTINUE DO 2307 I=1,IMAX FLX0(I,1)=TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) 1 +CSOUR(I,1) 2307 CONTINUE C---THE KP TERMS FOR K=1... DO 2303 KP=2,LP1 DO 2303 I=1,IMAX FLX0(I,1)=FLX0(I,1)+ OSS(I,KP)*TO3SP(I,KP-1) 1 +SS2(I,KP)*CNTTAU(I,KP-1) 2 +CSS(I,KP)*CO21(I,KP,1) 3 +DTC(I,KP)*EMISS(I,KP-1) 2303 CONTINUE C SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER C CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS. C CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, 1 EXCTS0,CTSO30,GXCTS0, 1 CLDFAC,TEMP,PRESS,VAR1,VAR2, 2 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, 3 CO2SP1,CO2SP2,CO2SP) C C THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2 C EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800- C 990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE C CONTAINED IN CTSO3, COMPUTED IN SPA88. C DO 998 I=1,IMAX VTMP3(I,1)=1. 998 CONTINUE DO 999 K=1,L DO 999 I=1,IMAX VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1) 999 CONTINUE DO 1001 K=1,L DO 1001 I=1,IMAX CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* 1 (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + 2 SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K))) 1001 CONTINUE C DO 1011 K=1,L DO 1011 I=1,IMAX VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - 1 CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K))) 1011 CONTINUE DO 1012 I=1,IMAX FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* 1 (E1CTS1(I,LP1)-E1CTW1(I,LP1)) 1012 CONTINUE DO 1014 K=1,L DO 1013 I=1,IMAX FLX1E1(I)=FLX1E1(I)+VTMP3(I,K) 1013 CONTINUE 1014 CONTINUE C ... DITTO FOR CLEAR SKY ... DO 2998 I=1,IMAX VTMP3(I,1)=1. 2998 CONTINUE DO 2999 K=1,L DO 2999 I=1,IMAX VTMP3(I,K+1)=CNTTAU(I,K) 2999 CONTINUE DO 2001 K=1,L DO 2001 I=1,IMAX CTS0(I,K)=RADCON*DELP(I,K)*(TC(I,K)* 1 (E1CTW2(I,K)-E1CTW1(I,K)) + 2 SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K))) 2001 CONTINUE C DO 2011 K=1,L DO 2011 I=1,IMAX VTMP3(I,K)=TC(I,K)*(E1CTS1(I,K)-E1CTW1(I,K) - 1 (E1CTS2(I,K)-E1CTW2(I,K))) 2011 CONTINUE DO 2012 I=1,IMAX FLX1E0(I)=TC(I,LP1)* 1 (E1CTS1(I,LP1)-E1CTW1(I,LP1)) 2012 CONTINUE DO 2014 K=1,L DO 2013 I=1,IMAX FLX1E0(I)=FLX1E0(I)+VTMP3(I,K) 2013 CONTINUE 2014 CONTINUE C C---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1 CASES. C CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL C EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS. C DO 321 K=2,LM1 KLEN=K C DO 3218 KK=1,LP1-K DO 3218 I=1,IMAX AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K) 3218 CONTINUE DO 1803 I=1,IMAX AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I) 1803 CONTINUE C---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT C WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL C AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS C BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE C THEIR FLUXES SEPARASTELY. C CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2) DO 322 KK=1,LP1-K DO 322 I=1,IMAX AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K) AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K) AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K) CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1) 322 CONTINUE C DO 3221 KK=1,LP1-K DO 3221 I=1,IMAX FAC1(I,KK+K-1)=BO3RND(2)*AVPHO3(I,KK+K-1)/AVMO3(I,KK+K-1) VTMP3(I,KK+K-1)=HAF*(FAC1(I,KK+K-1)* 1 (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,KK+K-1))/FAC1(I,KK+K-1))-ONE)) TO31D(I,KK+K-1)=EXP(HM1EZ*(VTMP3(I,KK+K-1)+SKO3R*AVVO2(I,KK+K-1))) OVER1D(I,KK+K-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,KK+K-1))+ 1 SKC1R*AVVO2(I,KK+K-1))) CO21(I,KK+K,K)=OVER1D(I,KK+K-1)*CO21(I,KK+K,K) 3221 CONTINUE DO 3223 KP=K+1,LP1 DO 3223 I=1,IMAX CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP) 3223 CONTINUE C---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION DO 1804 I=1,IMAX RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K) 1804 CONTINUE C---THE KP TERMS FOR ARBIRRARY K.. DO 3423 KP=K+1,LP1 DO 3423 I=1,IMAX FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) 1 +SS2(I,KP)*CONT1D(I,KP-1) 2 +CSS(I,KP)*CO21(I,KP,K) 3 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K) 3423 CONTINUE DO 3425 KP=K+1,LP1 DO 3425 I=1,IMAX FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) 1 +SS2(I,K)*CONT1D(I,KP-1) 2 +CSS(I,K)*CO21(I,K,KP) 3 +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP) 3425 CONTINUE C .... DITTO FOR CLEAR SKY .. CLDFAC=1. DO 2423 KP=K+1,LP1 DO 2423 I=1,IMAX FLX0(I,K)=FLX0(I,K)+ OSS(I,KP)*TO31D(I,KP-1) 1 +SS2(I,KP)*CONT1D(I,KP-1) 2 +CSS(I,KP)*CO21(I,KP,K) 3 +DTC(I,KP)*EMISS(I,KP-1) 2423 CONTINUE DO 2425 KP=K+1,LP1 DO 2425 I=1,IMAX FLX0(I,KP)=FLX0(I,KP)+ OSS(I,K)*TO31D(I,KP-1) 1 +SS2(I,K)*CONT1D(I,KP-1) 2 +CSS(I,K)*CO21(I,K,KP) 3 +DTC(I,K)*EMISSB(I,KP-1) 2425 CONTINUE 321 CONTINUE C C NOW DO K=L CASE. SINCE THE KP LOOP IS LENGTH 1, MANY SIMPLIFI- C CATIONS OCCUR. ALSO, THE CO2 QUANTITIES (AS WELL AS THE EMISS C QUANTITIES) ARE COMPUTED IN THE NBL SEDCTION; THEREFORE, WE WANT C ONLY OVER,TO3 AND CONT1D (OVER(I,L),TO31D(I,L) AND CONT1D(I,L) C ACCORDING TO THE NOTATION. THUS NO CALL IS MADE TO THE E290 C SUBROUTINE. C THE THIRD SECTION CALCULATES BOUNDARY LAYER AND NEARBY LAYER C CORRECTIONS TO THE TRANSMISSION FUNCTIONS OBTAINED ABOVE. METHODS C ARE GIVEN IN REF. (4). C THE FOLLOWING RATIOS ARE USED IN VARIOUS NBL CALCULATIONS: C C THE REMAINING CALCULATIONS ARE FOR : C 1) THE (K,K) TERMS, K=2,LM1; C 2) THE (L,L) TERM C 3) THE (L,LP1) TERM C 4) THE (LP1,L) TERM C 5) THE (LP1,LP1) TERM. C EACH IS UNIQUELY HANDLED; DIFFERENT FLUX TERMS ARE COMPUTED C DIFFERENTLY C C C FOURTH SECTION OBTAINS WATER TRANSMISSION FUNCTIONS C USED IN Q(APPROX) CALCULATIONS AND ALSO MAKES NBL CORRECTIONS: C 1) EMISS (I,J) IS THE TRANSMISSION FUNCTION MATRIX OBTAINED C BY CALLING SUBROUTINE E1E288; C 2) "NEARBY LAYER" CORRECTIONS (EMISS(I,I)) ARE OBTAINED C USING SUBROUTINE E3V88; C 3) SPECIAL VALUES AT THE SURFACE (EMISS(L,LP1),EMISS(LP1,L), C EMISS(LP1,LP1)) ARE CALCULATED. C C C OBTAIN ARGUMENTS FOR E1E288 AND E3V88: C DO 821 I=1,IMAX TPL(I,1)=TEMP(I,L) TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L)) TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L)) 821 CONTINUE DO 823 K=2,L DO 823 I=1,IMAX TPL(I,K)=T(I,K) TPL(I,K+L)=T(I,K) 823 CONTINUE C C---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES, C DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1) DO 833 I=1,IMAX AVEPHI(I,1)=VAR2(I,L) AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L) 833 CONTINUE CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP) C C CALL E3V88 FOR NBL H2O TRANSMISSIVITIES CALL E3V88(EMD,TPL,EMPL) C C COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS C USING METHODS FOR H2O GIVEN IN REF. (4) DO 851 K=2,L DO 851 I=1,IMAX EMISDG(I,K)=EMD(I,K+L)+EMD(I,K) 851 CONTINUE C C NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN C LWR88 DO 861 I=1,IMAX EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ 1 EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2)) EMISDG(I,LP1)=TWO*EMD(I,LP1) EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ * EMX2(I) 861 CONTINUE DO 331 I=1,IMAX FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L) VTMP3(I,L)=HAF*(FAC1(I,L)* 1 (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE)) TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L))) OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ 1 SKC1R*CNTVAL(I,L))) CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1) RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L) 331 CONTINUE DO 618 K=1,L DO 618 I=1,IMAX RLOG(I,K)=LOG(RLOG(I,K)) 618 CONTINUE DO 601 K=1,LM1 DO 601 I=1,IMAX DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) ALP(I,K+L)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1) 601 CONTINUE DO 603 K=1,L DO 603 I=1,IMAX DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K)) ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K) 603 CONTINUE DO 625 I=1,IMAX ALP(I,LL)=-RLOG(I,L) ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1))) 625 CONTINUE C THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE C FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION. C C PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND C***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY C EVALUATED. DO 631 K=1,LLP1 DO 631 I=1,IMAX C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2)) 631 CONTINUE DO 641 I=1,IMAX CO21(I,LP1,LP1)=ONE+C(I,L) CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* 1 C(I,LLM1))/(P(I,LP1)-PRESS(I,L)) CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- 1 (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1)) 641 CONTINUE DO 643 K=2,L DO 643 I=1,IMAX CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1)) 643 CONTINUE C C COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE C ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS C USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4). DO 651 K=1,LM1 DO 651 I=1,IMAX CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1) CSUB(I,K+L)=CNTVAL(I,K)*DELPR2(I,K+1) 651 CONTINUE C---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED DO 655 K=1,LLM2 DO 655 I=1,IMAX CSUB2(I,K+1)=SKO3R*CSUB(I,K+1) C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* 1 (HP166666-CSUB(I,K+1)*H41666M2)) C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* 1 (HP166666-CSUB2(I,K+1)*H41666M2)) 655 CONTINUE DO 661 I=1,IMAX CONTDG(I,LP1)=1.+C(I,LLM1) TO3DG(I,LP1)=1.+C2(I,LLM1) 661 CONTINUE DO 663 K=2,L DO 663 I=1,IMAX CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K)) TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K)) 663 CONTINUE C---NOW OBTAIN FLUXES C C FOR THE DIAGONAL TERMS... DO 871 K=2,LP1 DO 871 I=1,IMAX FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) 1 +SS2(I,K)*CONTDG(I,K) 2 +OSS(I,K)*TO3DG(I,K) 3 +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K) 871 CONTINUE C FOR THE TWO OFF-DIAGONAL TERMS... DO 873 I=1,IMAX FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) 1 +DTC(I,LP1)*EMSPEC(I,2) 2 +OSS(I,LP1)*TO31D(I,L) 3 +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L) FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) 1 +OSS(I,L)*TO31D(I,L) 2 +SS2(I,L)*CONT1D(I,L) 3 +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1) 873 CONTINUE C ... DITTO FOR CLEAR SKY ... CLDFAC =1. DO 2871 K=2,LP1 DO 2871 I=1,IMAX FLX0(I,K)=FLX0(I,K)+ DTC(I,K)*EMISDG(I,K) 1 +SS2(I,K)*CONTDG(I,K) 2 +OSS(I,K)*TO3DG(I,K) 3 +CSS(I,K)*CO21(I,K,K) 2871 CONTINUE C FOR THE TWO OFF-DIAGONAL TERMS... DO 2873 I=1,IMAX FLX0(I,L)=FLX0(I,L)+ CSS(I,LP1)*CO21(I,LP1,L) 1 +DTC(I,LP1)*EMSPEC(I,2) 2 +OSS(I,LP1)*TO31D(I,L) 3 +SS2(I,LP1)*CONT1D(I,L) FLX0(I,LP1)=FLX0(I,LP1)+ CSS(I,L)*CO21(I,L,LP1) 1 +OSS(I,L)*TO31D(I,L) 2 +SS2(I,L)*CONT1D(I,L) 3 +DTC(I,L)*EMSPEC(I,1) 2873 CONTINUE C C FINAL SECTION OBTAINS EMISSIVITY HEATING RATES, C TOTAL HEATING RATES AND THE FLUX AT THE GROUND C C .....CALCULATE THE EMISSIVITY HEATING RATES DO 1101 K=1,L DO 1101 I=1,IMAX HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K) 1101 CONTINUE C .....CALCULATE THE TOTAL HEATING RATES DO 1103 K=1,L DO 1103 I=1,IMAX HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K) 1103 CONTINUE C .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE C TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1) DO 1111 K=1,L DO 1111 I=1,IMAX VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1 1111 CONTINUE DO 1115 I=1,IMAX TOPFLX(I)=FLX1E1(I)+GXCTS(I) FLXNET(I,1)=TOPFLX(I) 1115 CONTINUE C---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS C THE THICK CLOUD SECTION IS INVOKED. DO 1123 K=2,LP1 DO 1123 I=1,IMAX FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1) 1123 CONTINUE DO 1125 I=1,IMAX GRNFLX(I)=FLXNET(I,LP1) 1125 CONTINUE C ... DITTO FOR CLEAR SKY .. CLDFAC=1. DO 2101 K=1,L DO 2101 I=1,IMAX HEATEM(I,K)=RADCON*(FLX0(I,K+1)-FLX0(I,K))*DELP(I,K) 2101 CONTINUE C .....CALCULATE THE TOTAL HEATING RATES DO 2103 K=1,L DO 2103 I=1,IMAX HEATR0(I,K)=HEATEM(I,K)-CTS0(I,K)-CTSO30(I,K)+EXCTS0(I,K) 2103 CONTINUE C .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE C TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1) DO 2111 K=1,L DO 2111 I=1,IMAX VSUM1(I,K)=HEATR0(I,K)*DELP2(I,K)*RADCON1 2111 CONTINUE DO 2115 I=1,IMAX TOPFX0(I)=FLX1E0(I)+GXCTS0(I) FLXNT0(I,1)=TOPFX0(I) 2115 CONTINUE C---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS C THE THICK CLOUD SECTION IS INVOKED. DO 2123 K=2,LP1 DO 2123 I=1,IMAX FLXNT0(I,K)=FLXNT0(I,K-1)+VSUM1(I,K-1) 2123 CONTINUE DO 2125 I=1,IMAX GRNFX0(I)=FLXNT0(I,LP1) 2125 CONTINUE C C THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD C FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT, C FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED. C***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE C ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS. C ICNT=0 C DO 1301 I=1,IMAX C ICNT=ICNT+NCLDS(I) C301 CONTINUE C IF (ICNT.EQ.0) GO TO 6999 C---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW C KCLDS=NCLDS(1) C DO 2106 I=2,IMAX C KCLDS=MAX(NCLDS(I),KCLDS) C106 CONTINUE C C C***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF C THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE C BEEN DEFINED!). C DO 1361 KK=1,KCLDS C KMIN=LP1 C KMAX=0 C DO 1362 I=1,IMAX C J1=KTOP(I,KK+1) C IF (J1.EQ.1) GO TO 1362 C J3=KBTM(I,KK+1) C IF (J3.GT.J1) THEN C PTOP(I)=P(I,J1) C PBOT(I)=P(I,J3+1) C FTOP(I)=FLXNET(I,J1) C FBOT(I)=FLXNET(I,J3+1) C***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC) C DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I)) C KMIN=MIN(KMIN,J1) C KMAX=MAX(KMAX,J3) C ENDIF C362 CONTINUE C KMIN=KMIN+1 C***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR C ALL LEVELS. C DO 1365 K=KMIN,KMAX C DO 1363 I=1,IMAX C IF (KTOP(I,KK+1).EQ.1) GO TO 1363 C IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN C Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I) CORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) + CORIGINAL1 Z1(I,K)*CAMT(I,KK+1) C FLXNET(I,K)=Z1(I,K) C ENDIF C363 CONTINUE C365 CONTINUE C361 CONTINUE C***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN C THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY C THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED. C DO 6051 K=1,LP1 C DO 6051 I=1,IMAX C FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) + C 1 Z1(I,K)*CAMT(I,NC) C051 CONTINUE C***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS. C DO 1401 K=1,LP1 C DO 1401 I=1,IMAX C IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I) C 1 .AND. (NC-1).LE.NCLDS(I)) THEN C FLXNET(I,K)=FLXTHK(I,K) C ENDIF C401 CONTINUE C C******END OF CLOUD LOOP***** C6001 CONTINUE C6999 CONTINUE C***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE C REVISED FLUXES: C DO 6101 K=1,L C DO 6101 I=1,IMAX C HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K) C6101 CONTINUE C THE THICK CLOUD SECTION ENDS HERE. RETURN END SUBROUTINE HCONST CFPP$ NOCONCUR R C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C SUBROUTINE HCONST DEFINES VARIABLES TO REPRESENT FLOATING- C POINT CONSTANTS. C C COMDECK HCON CONTAINS THE COMMON BLOCK FOR THESE FLOATING- C POINT CONSTANTS. C C THE NAMING CONVENTIONS FOR THE FLOATING-POINT VARIABLES ARE C AS FOLLOWS: C C 1) PHYSICAL AND MATHEMATICAL CONSTANTS WILL BE GIVEN NAMES C RELEVANT TO THEIR MEANING C 2) OTHER CONSTANTS WILL BE GIVEN NAMES RELEVANT TO THEIR VALUE C AND ADHERING TO THE FOLLOWING CONVENTIONS: C A) THE FIRST LETTER WILL BE REPRESENTED WITH AN 'H' EXCEPT C FOR I) AND J) BELOW C B) A DECIMAL POINT WILL BE REPRESENTED WITH A 'P' C C) THERE WILL BE NO EMBEDDED '0'(ZERO); ALL 0'S WILL C BE REPRESENTED WITH A 'Z' C D) A MINUS SIGN WILL BE REPRESENTED WITH AN 'M' C E) THE DECIMAL POINT IS ASSUMED AFTER THE FIRST DIGIT FOR C NUMBERS WITH EXPONENTS C F) POSITIVE EXPONENTS ARE INDICATED WITH 'E';NEGATIVE C EXPONENTS WITH 'M' C G) DIGITS ARE TRUNCATED IN ORDER TO HAVE NO MORE THAN 8 C CHARACTERS PER NAME C H) NUMBERS LESS THAN 0.1 AND GREATER THAN 10. WILL BE C REPRESENTED IN EXPONENT FORMAT (EXCEPT A FEW SPECIAL CASES) C I) THE WHOLE NUMBERS FROM 0.0 THROUGH 10.,AND 20.,30.,40.,50., C 60.,70.,80.,90.,100.,WILL BE SPELLED OUT C J) GOOD JUDGMENT WILL PREVAIL OVER ALL CONVENTIONS C C EXAMPLES C CONSTANT VARIABLE NAME CONVENTION C 600. LHEATC 1) C 680. LHEATS 1) C 1.4142 SQROOT2 1) C 2.0 TWO 2)-(I) C -3.0 HM3PZ 2)-(A,B,D) C 310. C31E2 2)-(A,E,F,H) C -0.7239E-9 HM723M1Z 2)-(A,C,D,E,F,G,H) C 0.0 ZERO 2)-(I) C 0.1 HP1 2)-(A,B,H) C 0.01 H1M2 2)-(A,E,F,H) C 30. THIRTY 2)-(H,I) C 0.5 HAF 2)-(J) C 9.0 HNINE 2)-(J) C C******THE FOLLOWING ARE PHYSICAL CONSTANTS***** C ARRANGED IN ALPHABETICAL ORDER AMOLWT=28.9644 CSUBP=1.00484E7 DIFFCTR=1.66 G=980.665 GINV=1./G GRAVDR=980.0 O3DIFCTR=1.90 P0=1013250. P0INV=1./P0 GP0INV=GINV*P0INV P0XZP2=202649.902 P0XZP8=810600.098 P0X2=2.*1013250. RADCON=8.427 RADCON1=1./8.427 RATCO2MW=1.519449738 RATH2OMW=.622 RGAS=8.3142E7 RGASSP=8.31432E7 SECPDA=8.64E4 C C******THE FOLLOWING ARE MATHEMATICAL CONSTANTS******* C ARRANGED IN DECREASING ORDER HUNDRED=100. HNINETY=90. SIXTY=60. FIFTY=50. TEN=10. EIGHT=8. FIVE=5. FOUR=4. THREE=3. TWO=2. ONE=1. HAF=0.5 QUARTR=0.25 ZERO=0. C C******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S) C ARRANGED IN DECREASING ORDER H83E26=8.3E26 H71E26=7.1E26 H1E15=1.E15 H1E13=1.E13 H1E11=1.E11 H1E8=1.E8 H2E6=2.0E6 H1E6=1.0E6 H69766E5=6.97667E5 H4E5=4.E5 H165E5=1.65E5 H5725E4=57250. H488E4=48800. H1E4=1.E4 H24E3=2400. H20788E3=2078.8 H2075E3=2075. H18E3=1800. H1224E3=1224. H67390E2=673.9057 H5E2=500. H3082E2=308.2 H3E2=300. H2945E2=294.5 H29316E2=293.16 H26E2=260.0 H25E2=250. H23E2=230. H2E2=200.0 H15E2=150. H1386E2=138.6 H1036E2=103.6 H8121E1=81.21 H35E1=35. H3116E1=31.16 H28E1=28. H181E1=18.1 H18E1=18. H161E1=16.1 H16E1=16. H1226E1=12.26 H9P94=9.94 H6P08108=6.081081081 H3P6=3.6 H3P5=3.5 H2P9=2.9 H2P8=2.8 H2P5=2.5 H1P8=1.8 H1P4387=1.4387 H1P41819=1.418191 H1P4=1.4 H1P25892=1.258925411 H1P082=1.082 HP816=0.816 HP805=0.805 HP8=0.8 HP60241=0.60241 HP602409=0.60240964 HP6=0.6 HP526315=0.52631579 HP518=0.518 HP5048=0.5048 HP3795=0.3795 HP369=0.369 HP26=0.26 HP228=0.228 HP219=0.219 HP166666=.166666 HP144=0.144 HP118666=0.118666192 HP1=0.1 C (NEGATIVE EXPONENTIALS BEGIN HERE) H658M2=0.0658 H625M2=0.0625 H44871M2=4.4871E-2 H44194M2=.044194 H42M2=0.042 H41666M2=0.0416666 H28571M2=.02857142857 H2118M2=0.02118 H129M2=0.0129 H1M2=.01 H559M3=5.59E-3 H3M3=0.003 H235M3=2.35E-3 H1M3=1.0E-3 H987M4=9.87E-4 H323M4=0.000323 H3M4=0.0003 H285M4=2.85E-4 H1M4=0.0001 H75826M4=7.58265E-4 H6938M5=6.938E-5 H394M5=3.94E-5 H37412M5=3.7412E-5 H15M5=1.5E-5 H1439M5=1.439E-5 H128M5=1.28E-5 H102M5=1.02E-5 H1M5=1.0E-5 H7M6=7.E-6 H4999M6=4.999E-6 H451M6=4.51E-6 H25452M6=2.5452E-6 H1M6=1.E-6 H391M7=3.91E-7 H1174M7=1.174E-7 H8725M8=8.725E-8 H327M8=3.27E-8 H257M8=2.57E-8 H1M8=1.0E-8 H23M10=2.3E-10 H14M10=1.4E-10 H11M10=1.1E-10 H1M10=1.E-10 H83M11=8.3E-11 H82M11=8.2E-11 H8M11=8.E-11 H77M11=7.7E-11 H72M11=7.2E-11 H53M11=5.3E-11 H48M11=4.8E-11 H44M11=4.4E-11 H42M11=4.2E-11 H37M11=3.7E-11 H35M11=3.5E-11 H32M11=3.2E-11 H3M11=3.0E-11 H28M11=2.8E-11 H24M11=2.4E-11 H23M11=2.3E-11 H2M11=2.E-11 H18M11=1.8E-11 H15M11=1.5E-11 H14M11=1.4E-11 H114M11=1.14E-11 H11M11=1.1E-11 H1M11=1.E-11 H96M12=9.6E-12 H93M12=9.3E-12 H77M12=7.7E-12 H74M12=7.4E-12 H65M12=6.5E-12 H62M12=6.2E-12 H6M12=6.E-12 H45M12=4.5E-12 H44M12=4.4E-12 H4M12=4.E-12 H38M12=3.8E-12 H37M12=3.7E-12 H3M12=3.E-12 H29M12=2.9E-12 H28M12=2.8E-12 H24M12=2.4E-12 H21M12=2.1E-12 H16M12=1.6E-12 H14M12=1.4E-12 H12M12=1.2E-12 H8M13=8.E-13 H46M13=4.6E-13 H36M13=3.6E-13 H135M13=1.35E-13 H12M13=1.2E-13 H1M13=1.E-13 H3M14=3.E-14 H15M14=1.5E-14 H14M14=1.4E-14 H101M16=1.01E-16 H1M16=1.0E-16 H1M17=1.E-17 H1M18=1.E-18 H1M19=1.E-19 H1M20=1.E-20 H1M21=1.E-21 H1M22=1.E-22 H1M23=1.E-23 H1M24=1.E-24 H26M30=2.6E-30 H14M30=1.4E-30 H25M31=2.5E-31 H21M31=2.1E-31 H12M31=1.2E-31 H9M32=9.E-32 H55M32=5.5E-32 H45M32=4.5E-32 H4M33=4.E-33 H62M34=6.2E-34 C-CRA H1M60=1.0E-60 H1M60=1.0D-60 C C******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S) C ARRANGED IN DESCENDING ORDER HM2M2=-.02 HM6666M2=-.066667 HMP5=-0.5 HMP575=-0.575 HMP66667=-.66667 HMP805=-0.805 HM1EZ=-1. HM13EZ=-1.3 HM19EZ=-1.9 HM1E1=-10. HM1597E1=-15.97469413 HM161E1=-16.1 HM1797E1=-17.97469413 HM181E1=-18.1 HM8E1=-80. HM1E2=-100. C RETURN END SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, 1 GRNFX0,TOPFX0, 1 PRESS,TEMP,RH2O,QO3,CLDFAC, 2 CAMT,NCLDS,KTOP,KBTM) CFPP$ NOCONCUR R C SUBROUTINE LWR88 COMPUTES TEMPERATURE-CORRECTED CO2 TRANSMISSION C FUNCTIONS AND ALSO COMPUTES THE PRESSURE GRID AND LAYER OPTICAL C PATHS. C INPUTS: (COMMON BLOCKS) C CLDFAC CLDCOM C PRESS,TEMP,RH2O,QO3 RADISW C CAMT,NCLDS,KTOP,KBTM RADISW C CO251,CO258,CDT51,CDT58 CO2BD3 C C2D51,C2D58,CO2M51,CO2M58 CO2BD3 C CDTM51,CDTM58,C2DM51,C2DM58 CO2BD3 C STEMP,GTEMP CO2BD3 C CO231,CO238,CDT31,CDT38 CO2BD2 C C2D31,C2D38 CO2BD2 C CO271,CO278,CDT71,CDT78 CO2BD4 C C2D71,C2D78 CO2BD4 C BETINW BDWIDE C OUTPUTS: C HEATRA,GRNFLX,TOPFLX LWOUT C CALLED BY: C RADMN OR INPUT ROUTINE OF MODEL C CALLS: C FST88 C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION C FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND C SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985), C***COMMON CO2BD3 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED C ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE C DATA ARE IN BLOCK DATA BD3: C CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251 C CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258 C C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251 C C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251 C CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE C LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR C NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB C CO2M58 = SAME AS CO2M51,WITH P(SFC)= ^810 MB C CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51 C CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58 C C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51 C C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58 C STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL C STRUCTURE WITH P(SFC)=1013.25 MB C GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL C STRUCTURE WITH P(SFC)=1013.25 MB. C B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN. C CORRECTION FOR T(K). (SEE REF. 4 AND BD3) C B1 = TEMP. COEFFICIENT, USED ALONG WITH B0 C B2 = TEMP. COEFFICIENT, USED ALONG WITH B0 C B3 = TEMP. COEFFICIENT, USED ALONG WITH B0 C COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1), 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L), 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L), 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3 C C***COMMON CO2BD2 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM C CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2. C CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231 C CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238 C C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231 C C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231 C COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1), 1 CDT38(LP1),C2D31(LP1),C2D38(LP1) C C***COMMON CO2BD4 CONTAINS CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE C AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM C CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4. C CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271 C CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278 C C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271 C C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271 C COMMON / CO2BD4 / CO271(LP1),CO278(LP1),CDT71(LP1), 1 CDT78(LP1),C2D71(LP1),C2D78(LP1) C C***COMMON CO2BD5 CONTAINS CO2 TRANSMISSION FUNCTIONS FOR THE 2270- C 2380 PART OF THE 4.3 UM CO2 BAND. THESE DATA ARE IN BLOCK DATA BD5. C CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) C WITH P(SFC)=1013.25 MB C CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) C WITH P(SFC)= ^810 MB C COMMON / CO2BD5 / CO211(LP1),CO218(LP1) C C COMMON BLOCK BANDTA CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING 10 CM-1 WIDE BANDS.THE 15 UM CO2 COMPLEX C IS 2 BANDS,560-670 AND 670-800 CM-1. OZONE COEFFICIENTS ARE C IN 3 BANDS,670-800 (14.1 UM),990-1070 AND 1070-1200 (9.6 UM). C THE (NBLW) BANDS NOW INCLUDE: C 56 BANDS, 10 CM-1 WIDE 0 - 560 CM-1 C 2 BANDS, 15 UM COMPLEX 560 - 670 CM-1 C 670 - 800 CM-1 C 3 "CONTINUUM" BANDS 800 - 900 CM-1 C 900 - 990 CM-1 C 1070 - 1200 CM-1 C 1 BAND FOR 9.6 UM BAND 990 - 1070 CM-1 C 100 BANDS, 10 CM-1 WIDE 1200 - 2200 CM-1 C 1 BAND FOR 4.3 UM SRC 2270 - 2380 CM-1 C THUS NBLW PRESENTLY EQUALS 163 C ALL BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C C ARNDM = RANDOM "A" PARAMETER FOR (NBLW) BANDS C BRNDM = RANDOM "B" PARAMETER FOR (NBLW) BANDS C BETAD = CONTINUUM COEFFICIENTS FOR (NBLW) BANDS C AP,BP = CAPPHI COEFFICIENTS FOR (NBLW) BANDS C ATP,BTP = CAPPSI COEFFICIENTS FOR (NBLW) BANDS C BANDLO = LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C BANDHI = HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C AO3RND = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3RND = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15 = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C DATA FOR ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND ARE OBTAINED BY C USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS ARE FROM C ROBERTS (1976). COMMON / BANDTA / ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW), 1 BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW), 2 BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2) C C COMMON BLOCK BDWIDE CONTAINS RANDOM BAND PARAMETERS FOR SPECIFIC C WIDE BANDS. AT PRESENT,THE INFORMATION CONSISTS OF 1) RANDOM C MODEL PARAMETERS FOR THE 15 UM BAND,560-800 CM-1; 2) THE C CONTINUUM COEFFICIENT FOR THE 800-990,1070-1200 CM-1 BAND C SPECIFICALLY: C AWIDE = RANDOM "A" PARAMETER FOR BAND C BWIDE = RANDOM "B" PARAMETER FOR BAND C BETAWD = CONTINUUM COEFFICIENTS FOR BAND C APWD,BPWD = CAPPHI COEFFICIENTS FOR BAND C ATPWD,BTPWD = CAPPSI COEFFICIENTS FOR BAND C BDLOWD = LOWEST FREQUENCY IN EACH FREQ BAND C BDHIWD = HIGHEST FREQUENCY IN EACH FREQ BAND C AB15WD = THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINW = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C SKO2D = 1./BETINW, USED IN SPA88 FOR CONT. COEFFS C SKC1R = BETAWD/BETINW, USED FOR CONT. COEFF. FOR C 15 UM BAND IN FST88 C SKO3R = RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO C BETINW, USED FOR 9.6 UM CONT COEFF IN FST88 C DATA FOR AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). COMMON / BDWIDE / AWIDE,BWIDE,BETAWD, 1 APWD,BPWD,ATPWD,BTPWD, 2 BDLOWD,BDHIWD,BETINW, 3 AB15WD,SKO2D,SKC1R,SKO3R C C COMMON BLOCK BDCOMB CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING COMBINED WIDE FREQUENCY BANDS BETWEEN 160 AND C 1200 CM-1,AS WELL AS THE 2270-2380 BAND FOR SOURCE CALC. C BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1 C BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS) C FOR 560-1200 CM-1 C BAND 15: FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE C CALCULATION ONLY C THUS NBLY PRESENTLY EQUALS 15 C C BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C ACOMB = RANDOM "A" PARAMETER FOR (NBLY) BANDS C BCOMB = RANDOM "B" PARAMETER FOR (NBLY) BANDS C BETACM = CONTINUUM COEFFICIENTS FOR (NBLY) BANDS C APCM,BPCM = CAPPHI COEFFICIENTS FOR (NBLY) BANDS C ATPCM,BTPCM = CAPPSI COEFFICIENTS FOR (NBLY) BANDS C BDLOCM = LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C BDHICM = HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C AO3CM = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3CM = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15CM = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINC = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C IBAND = INDEX NO OF THE 40 WIDE BANDS USED IN C COMBINED WIDE BAND CALCULATIONS. IN OTHER C WORDS,INDEX TELLING WHICH OF THE 40 WIDE C BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN C EACH OF THE FIRST 8 COMBINED WIDE BANDS C DATA FOR ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). IBAND INDEX VALUES ARE OBTAINED BY C EXPERIMENTATION. COMMON / BDCOMB / IBAND(40),ACOMB(NBLY),BCOMB(NBLY), 1 BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), 2 BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC, 3 AO3CM(3),BO3CM(3),AB15CM(2) C C DIMENSION PRESS(IMBX,LP1),TEMP(IMBX,LP1),RH2O(IMBX,L),QO3(IMBX,L) DIMENSION CLDFAC(IMBX,LP1,LP1),CAMT(IMBX,LP1) DIMENSION NCLDS(IMAX),KTOP(IMBX,LP1),KBTM(IMBX,LP1) DIMENSION HEATRA(IMBX,L),GRNFLX(IMAX),TOPFLX(IMAX) DIMENSION GRNFX0(IMAX),TOPFX0(IMAX) DIMENSION DELP2(IMBX,L) C DIMENSION QH2O(IMBX,L),T(IMBX,LP1) DIMENSION P(IMBX,LP1),DELP(IMBX,L) DIMENSION CO21(IMBX,LP1,LP1),CO2NBL(IMBX,L) DIMENSION CO2SP1(IMBX,LP1),CO2SP2(IMBX,LP1) DIMENSION VAR1(IMBX,L),VAR2(IMBX,L),VAR3(IMBX,L),VAR4(IMBX,L) DIMENSION CNTVAL(IMBX,LP1) DIMENSION TOTO3(IMBX,LP1),TPHIO3(IMBX,LP1),TOTPHI(IMBX,LP1) DIMENSION TOTVO2(IMBX,LP1),EMX1(IMAX),EMX2(IMAX),EMPL(IMBX,LLP1) C DIMENSION CO2R(IMBX,LP1),DIFT(IMBX,LP1) DIMENSION CO2R1(IMBX,LP1),DCO2D1(IMBX,LP1) DIMENSION D2CD21(IMBX,LP1),D2CD22(IMBX,LP1) DIMENSION CO2R2(IMBX,LP1),DCO2D2(IMBX,LP1) DIMENSION CO2MR(IMBX,L),CO2MD(IMBX,L),CO2M2D(IMBX,L) DIMENSION TDAV(IMBX,LP1),TSTDAV(IMBX,LP1), 1 VV(IMBX,L),VSUM3(IMBX,LP1),VSUM1(IMAX),VSUM2(IMAX) DIMENSION A1(IMAX),A2(IMAX) DIMENSION DCO2DT(IMBX,LP1),D2CDT2(IMBX,LP1) C DIMENSION TEXPSL(IMBX,LP1),TLSQU(IMBX,LP1) DIMENSION VSUM4(IMBX,L) EQUIVALENCE (VSUM3,TLSQU,TEXPSL) EQUIVALENCE (VV,VSUM4) C C****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP) C****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE C CORRECTIONS (TEXPSL) DO 103 K=2,L DO 103 I=1,IMAX P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K)) T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K)) 103 CONTINUE DO 105 I=1,IMAX P(I,1)=ZERO P(I,LP1)=PRESS(I,LP1) T(I,1)=TEMP(I,1) T(I,LP1)=TEMP(I,LP1) 105 CONTINUE DO 107 K=1,L DO 107 I=1,IMAX DELP2(I,K)=P(I,K+1)-P(I,K) DELP(I,K)=ONE/DELP2(I,K) 107 CONTINUE C****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF. C (THIS IS 1800.(1./TEMP-1./296.)) CMK if( temp(imax,lp1).lt.1. ) CLOSE(90) DO 125 K=1,LP1 DO 125 I=1,IMAX TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108 C...THEN TAKE EXPONENTIAL TEXPSL(I,K)=EXP(TEXPSL(I,K)) 125 CONTINUE C***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY C APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE C UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4). C THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND C VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND C O3,RESPECTIVELY. C DO 131 K=1,L DO 131 I=1,IMAX QH2O(I,K)=RH2O(I,K)*DIFFCTR C---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS C THE LEVEL PRESSURE (PRESS) VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4) VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3) C COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS. C (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR C (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE C USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT C SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF C AN ANGULAR INTEGRATION IS SEVERE. C CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ 1 (RH2O(I,K)+RATH2OMW) 131 CONTINUE C COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM DO 201 I=1,IMAX TOTPHI(I,1)=ZERO TOTO3(I,1)=ZERO TPHIO3(I,1)=ZERO TOTVO2(I,1)=ZERO 201 CONTINUE DO 203 K=2,LP1 DO 203 I=1,IMAX TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1) TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1) TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1) TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1) 203 CONTINUE C---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO C P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS. C---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO C P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1. C DO 801 I=1,IMAX EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV 801 CONTINUE C---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1) C OR TO PRESS(K+1) (INDEX LP2-LL) DO 811 K=1,L DO 811 I=1,IMAX EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV 811 CONTINUE DO 812 K=1,LM1 DO 812 I=1,IMAX EMPL(I,K+LP1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1))*GP0INV 812 CONTINUE DO 821 I=1,IMAX EMPL(I,1)=VAR2(I,L) EMPL(I,LLP1)=EMPL(I,LL) 821 CONTINUE C***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS C FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD. C TEMP. SOUNDING (DIFT) DO 161 I=1,IMAX TSTDAV(I,1)=ZERO TDAV(I,1)=ZERO 161 CONTINUE DO 162 K=1,LP1 DO 162 I=1,IMAX VSUM3(I,K)=TEMP(I,K)-STEMP(K) 162 CONTINUE DO 163 K=1,L DO 165 I=1,IMAX VSUM2(I)=GTEMP(K)*DELP2(I,K) VSUM1(I)=VSUM2(I)*VSUM3(I,K) TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I) TDAV(I,K+1)=TDAV(I,K)+VSUM1(I) 165 CONTINUE 163 CONTINUE C C****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2) DO 171 I=1,IMAX A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2 A2(I)=(P0-PRESS(I,LP1))/P0XZP2 171 CONTINUE C***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION C FUNCTIONS AND TEMP. DERIVATIVES C---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE C STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME) DO 184 K=1,LP1 DO 184 I=1,IMAX CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K) D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K)) DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K)) CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K) D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K)) DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K)) 184 CONTINUE DO 190 K=1,L DO 190 I=1,IMAX CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K) CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K)) CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K)) 190 CONTINUE C***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT C C THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING C 3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS C CALCULATION IS FOR (I,KP,1) DO 211 KP=2,LP1 DO 211 I=1,IMAX DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP) 211 CONTINUE DO 212 I=1,IMAX CO21(I,1,1)=1.0 CO2SP1(I,1)=1.0 CO2SP2(I,1)=1.0 212 CONTINUE DO 215 KP=2,LP1 DO 215 I=1,IMAX C---CALCULATIONS FOR KP>1 FOR K=1 CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1)) CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ 1 HAF*DIFT(I,KP)*D2CDT2(I,KP)) C---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE C SAME VALUE OF DIFT DUE TO SYMMETRY CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP)) CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ 1 HAF*DIFT(I,KP)*D2CDT2(I,KP)) 215 CONTINUE C THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW. C---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS C INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1)) DO 250 K=2,LP1 DO 250 I=1,IMAX CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* 1 D2CD21(I,K)) CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* 1 D2CD22(I,K)) 250 CONTINUE C C NEXT THE CASE WHEN K=2...L DO 220 K=2,L DO 222 KP=K+1,LP1 DO 222 I=1,IMAX DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ 1 (TSTDAV(I,KP)-TSTDAV(I,K)) CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K)) CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ 1 HAF*DIFT(I,KP)*D2CDT2(I,KP)) CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP)) CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ 1 HAF*DIFT(I,KP)*D2CDT2(I,KP)) 222 CONTINUE 220 CONTINUE C FINALLY THE CASE WHEN K=KP,K=2..LP1 DO 206 K=2,LP1 DO 206 I=1,IMAX DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1)) CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K) DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K)) D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K)) CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ 1 HAF*DIFT(I,K)*D2CDT2(I,K)) 206 CONTINUE C--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS . DO 260 K=1,L DO 260 I=1,IMAX CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* 1 VSUM3(I,K)*CO2M2D(I,K)) 260 CONTINUE C***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2) DO 264 K=1,LP1 DO 264 I=1,IMAX IF (T(I,K).LE.H25E2) THEN TLSQU(I,K)=B0+(T(I,K)-H25E2)* 1 (B1+(T(I,K)-H25E2)* 2 (B2+B3*(T(I,K)-H25E2))) ELSE TLSQU(I,K)=B0 ENDIF 264 CONTINUE C***APPLY TO ALL CO2 TFS DO 280 K=1,LP1 DO 282 KP=1,LP1 DO 282 I=1,IMAX CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP) 282 CONTINUE 280 CONTINUE DO 284 K=1,LP1 DO 286 I=1,IMAX CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1) CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1) 286 CONTINUE 284 CONTINUE DO 288 K=1,L DO 290 I=1,IMAX CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K) 290 CONTINUE 288 CONTINUE CALL FST88(HEATRA,GRNFLX,TOPFLX, 1 GRNFX0,TOPFX0, 1 QH2O,PRESS,P,DELP,DELP2,TEMP,T, 2 CLDFAC,NCLDS,KTOP,KBTM,CAMT, 3 CO21,CO2NBL,CO2SP1,CO2SP2, 4 VAR1,VAR2,VAR3,VAR4,CNTVAL, 5 TOTO3,TPHIO3,TOTPHI,TOTVO2, 6 EMX1,EMX2,EMPL) RETURN END C SUBROUTINE SPA88 COMPUTES EXACT CTS HEATING RATES AND FLUXES AND C CORRESPONDING CTS EMISSIVITY QUANTITIES FOR H2O,CO2 AND O3. C INPUTS: (COMMON BLOCKS) C ACOMB,BCOMB,APCM,BPCM BDCOMB C ATPCM,BTPCM,BETACM BDCOMB C BETINW BDWIDE C TEMP,PRESS RADISW C VAR1,VAR2,P,DELP,DELP2 KDACOM C TOTVO2,TO3SP,TO3SPC TFCOM C CO2SP1,CO2SP2,CO2SP TFCOM C CLDFAC CLDCOM C SKO2D TABCOM C SORC,CSOUR SRCCOM C OUTPUTS: C EXCTS,CTSO3 TFCOM C GXCTS RDFLUX C CALLED BY: C FST88 C CALLS: C SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, 1 EXCTS0,CTSO30,GXCTS0, 1 CLDFAC,TEMP,PRESS,VAR1,VAR2, 2 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, 3 CO2SP1,CO2SP2,CO2SP) CFPP$ NOCONCUR R C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK BANDTA CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING 10 CM-1 WIDE BANDS.THE 15 UM CO2 COMPLEX C IS 2 BANDS,560-670 AND 670-800 CM-1. OZONE COEFFICIENTS ARE C IN 3 BANDS,670-800 (14.1 UM),990-1070 AND 1070-1200 (9.6 UM). C THE (NBLW) BANDS NOW INCLUDE: C 56 BANDS, 10 CM-1 WIDE 0 - 560 CM-1 C 2 BANDS, 15 UM COMPLEX 560 - 670 CM-1 C 670 - 800 CM-1 C 3 "CONTINUUM" BANDS 800 - 900 CM-1 C 900 - 990 CM-1 C 1070 - 1200 CM-1 C 1 BAND FOR 9.6 UM BAND 990 - 1070 CM-1 C 100 BANDS, 10 CM-1 WIDE 1200 - 2200 CM-1 C 1 BAND FOR 4.3 UM SRC 2270 - 2380 CM-1 C THUS NBLW PRESENTLY EQUALS 163 C ALL BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C C ARNDM = RANDOM "A" PARAMETER FOR (NBLW) BANDS C BRNDM = RANDOM "B" PARAMETER FOR (NBLW) BANDS C BETAD = CONTINUUM COEFFICIENTS FOR (NBLW) BANDS C AP,BP = CAPPHI COEFFICIENTS FOR (NBLW) BANDS C ATP,BTP = CAPPSI COEFFICIENTS FOR (NBLW) BANDS C BANDLO = LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C BANDHI = HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C AO3RND = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3RND = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15 = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C DATA FOR ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND ARE OBTAINED BY C USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS ARE FROM C ROBERTS (1976). COMMON / BANDTA / ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW), 1 BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW), 2 BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2) C C COMMON BLOCK BDWIDE CONTAINS RANDOM BAND PARAMETERS FOR SPECIFIC C WIDE BANDS. AT PRESENT,THE INFORMATION CONSISTS OF 1) RANDOM C MODEL PARAMETERS FOR THE 15 UM BAND,560-800 CM-1; 2) THE C CONTINUUM COEFFICIENT FOR THE 800-990,1070-1200 CM-1 BAND C SPECIFICALLY: C AWIDE = RANDOM "A" PARAMETER FOR BAND C BWIDE = RANDOM "B" PARAMETER FOR BAND C BETAWD = CONTINUUM COEFFICIENTS FOR BAND C APWD,BPWD = CAPPHI COEFFICIENTS FOR BAND C ATPWD,BTPWD = CAPPSI COEFFICIENTS FOR BAND C BDLOWD = LOWEST FREQUENCY IN EACH FREQ BAND C BDHIWD = HIGHEST FREQUENCY IN EACH FREQ BAND C AB15WD = THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINW = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C SKO2D = 1./BETINW, USED IN SPA88 FOR CONT. COEFFS C SKC1R = BETAWD/BETINW, USED FOR CONT. COEFF. FOR C 15 UM BAND IN FST88 C SKO3R = RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO C BETINW, USED FOR 9.6 UM CONT COEFF IN FST88 C DATA FOR AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). COMMON / BDWIDE / AWIDE,BWIDE,BETAWD, 1 APWD,BPWD,ATPWD,BTPWD, 2 BDLOWD,BDHIWD,BETINW, 3 AB15WD,SKO2D,SKC1R,SKO3R C C COMMON BLOCK BDCOMB CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING COMBINED WIDE FREQUENCY BANDS BETWEEN 160 AND C 1200 CM-1,AS WELL AS THE 2270-2380 BAND FOR SOURCE CALC. C BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1 C BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS) C FOR 560-1200 CM-1 C BAND 15: FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE C CALCULATION ONLY C THUS NBLY PRESENTLY EQUALS 15 C C BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C ACOMB = RANDOM "A" PARAMETER FOR (NBLY) BANDS C BCOMB = RANDOM "B" PARAMETER FOR (NBLY) BANDS C BETACM = CONTINUUM COEFFICIENTS FOR (NBLY) BANDS C APCM,BPCM = CAPPHI COEFFICIENTS FOR (NBLY) BANDS C ATPCM,BTPCM = CAPPSI COEFFICIENTS FOR (NBLY) BANDS C BDLOCM = LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C BDHICM = HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C AO3CM = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3CM = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15CM = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINC = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C IBAND = INDEX NO OF THE 40 WIDE BANDS USED IN C COMBINED WIDE BAND CALCULATIONS. IN OTHER C WORDS,INDEX TELLING WHICH OF THE 40 WIDE C BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN C EACH OF THE FIRST 8 COMBINED WIDE BANDS C DATA FOR ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). IBAND INDEX VALUES ARE OBTAINED BY C EXPERIMENTATION. COMMON / BDCOMB / IBAND(40),ACOMB(NBLY),BCOMB(NBLY), 1 BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), 2 BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC, 3 AO3CM(3),BO3CM(3),AB15CM(2) C C DIMENSION SORC(IMBX,LP1,NBLY),CSOUR(IMBX,LP1) DIMENSION CLDFAC(IMBX,LP1,LP1) DIMENSION TEMP(IMBX,LP1),PRESS(IMBX,LP1) DIMENSION VAR1(IMBX,L),VAR2(IMBX,L) DIMENSION P(IMBX,LP1),DELP(IMBX,L),DELP2(IMBX,L) DIMENSION TOTVO2(IMBX,LP1),TO3SPC(IMBX,L),TO3SP(IMBX,LP1) DIMENSION CO2SP1(IMBX,LP1),CO2SP2(IMBX,LP1),CO2SP(IMBX,LP1) DIMENSION EXCTS(IMBX,L),CTSO3(IMBX,L),GXCTS(IMAX) DIMENSION EXCTS0(IMBX,L),CTSO30(IMBX,L),GXCTS0(IMAX) DIMENSION CTMP0(IMBX,LP1),CTMP20(IMBX,LP1),CTMP30(IMBX,LP1) C DIMENSION PHITMP(IMBX,L),PSITMP(IMBX,L),TT(IMBX,L), 1 FAC1(IMBX,L),FAC2(IMBX,L), 2 CTMP(IMBX,LP1),X(IMBX,L),Y(IMBX,L), 3 TOPM(IMBX,L),TOPPHI(IMBX,L), 4 CTMP3(IMBX,LP1),CTMP2(IMBX,LP1) DIMENSION F(IMBX,L),FF(IMBX,L),AG(IMBX,L),AGG(IMBX,L) EQUIVALENCE (F,AG,PHITMP) EQUIVALENCE (FF,AGG,PSITMP) C---COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM DO 101 K=1,L DO 101 I=1,IMAX X(I,K)=TEMP(I,K)-H25E2 Y(I,K)=X(I,K)*X(I,K) 101 CONTINUE C---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE C TRANSMISSION FCTNS AT THE TOP. DO 345 I=1,IMAX CTMP(I,1)=ONE CTMP2(I,1)=1. CTMP3(I,1)=1. 345 CONTINUE C... DITTO FOR THE CLEAR SKY CALCULATION... DO 2345 I=1,IMAX CTMP0(I,1)=ONE CTMP20(I,1)=1. CTMP30(I,1)=1. 2345 CONTINUE C***BEGIN LOOP ON FREQUENCY BANDS (1)*** C C---CALCULATION FOR BAND 1 (COMBINED BAND 1) C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 301 K=1,L DO 301 I=1,IMAX F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 301 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 315 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 315 CONTINUE DO 319 K=2,L DO 317 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 317 CONTINUE 319 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 321 K=1,L DO 321 I=1,IMAX FAC1(I,K)=ACOMB(1)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 321 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 353 K=1,L DO 353 I=1,IMAX EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=SORC(I,K,1)*(CTMP0(I,K+1)-CTMP0(I,K)) 353 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 361 I=1,IMAX GXCTS(I)= TT(I,L)*SORC(I,L,1)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,1)-SORC(I,L,1)) GXCTS0(I)=GXCTS(I) GXCTS(I)=CLDFAC(I,LP1,1)*GXCTS(I) 361 CONTINUE C C C-----CALCULATION FOR BAND 2 (COMBINED BAND 2) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 401 K=1,L DO 401 I=1,IMAX F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 401 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 415 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 415 CONTINUE DO 419 K=2,L DO 417 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 417 CONTINUE 419 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 421 K=1,L DO 421 I=1,IMAX FAC1(I,K)=ACOMB(2)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 421 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 453 K=1,L DO 453 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,2)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 453 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 461 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,2)-SORC(I,L,2))) 461 CONTINUE DO 2461 I=1,IMAX GXCTS0(I)=GXCTS0(I)+ TT(I,L)*SORC(I,L,2)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,2)-SORC(I,L,2)) 2461 CONTINUE C C-----CALCULATION FOR BAND 3 (COMBINED BAND 3) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 501 K=1,L DO 501 I=1,IMAX F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 501 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 515 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 515 CONTINUE DO 519 K=2,L DO 517 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 517 CONTINUE 519 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 521 K=1,L DO 521 I=1,IMAX FAC1(I,K)=ACOMB(3)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 521 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 553 K=1,L DO 553 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,3)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 553 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 561 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,3)-SORC(I,L,3))) 561 CONTINUE DO 2561 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,3)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,3)-SORC(I,L,3)) 2561 CONTINUE C C-----CALCULATION FOR BAND 4 (COMBINED BAND 4) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 601 K=1,L DO 601 I=1,IMAX F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 601 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 615 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 615 CONTINUE DO 619 K=2,L DO 617 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 617 CONTINUE 619 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 621 K=1,L DO 621 I=1,IMAX FAC1(I,K)=ACOMB(4)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 621 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 653 K=1,L DO 653 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,4)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 653 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 661 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,4)-SORC(I,L,4))) 661 CONTINUE DO 2661 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,4)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,4)-SORC(I,L,4)) 2661 CONTINUE C C-----CALCULATION FOR BAND 5 (COMBINED BAND 5) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 701 K=1,L DO 701 I=1,IMAX F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 701 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 715 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 715 CONTINUE DO 719 K=2,L DO 717 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 717 CONTINUE 719 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 721 K=1,L DO 721 I=1,IMAX FAC1(I,K)=ACOMB(5)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(5)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 721 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 753 K=1,L DO 753 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,5)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 753 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 761 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,5)-SORC(I,L,5))) 761 CONTINUE DO 2761 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,5)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,5)-SORC(I,L,5)) 2761 CONTINUE C C-----CALCULATION FOR BAND 6 (COMBINED BAND 6) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 801 K=1,L DO 801 I=1,IMAX F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 801 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 815 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 815 CONTINUE DO 819 K=2,L DO 817 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 817 CONTINUE 819 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 821 K=1,L DO 821 I=1,IMAX FAC1(I,K)=ACOMB(6)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(6)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 821 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 853 K=1,L DO 853 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,6)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 853 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 861 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,6)-SORC(I,L,6))) 861 CONTINUE DO 2861 I=1,IMAX GXCTS0(I)=GXCTS0(I)+ TT(I,L)*SORC(I,L,6)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,6)-SORC(I,L,6)) 2861 CONTINUE C C-----CALCULATION FOR BAND 7 (COMBINED BAND 7) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 901 K=1,L DO 901 I=1,IMAX F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 901 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 915 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 915 CONTINUE DO 919 K=2,L DO 917 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 917 CONTINUE 919 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 921 K=1,L DO 921 I=1,IMAX FAC1(I,K)=ACOMB(7)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(7)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 921 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 953 K=1,L DO 953 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,7)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,7)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 953 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 961 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,7)-SORC(I,L,7))) 961 CONTINUE DO 1961 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,7)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,7)-SORC(I,L,7)) 1961 CONTINUE C C-----CALCULATION FOR BAND 8 (COMBINED BAND 8) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1001 K=1,L DO 1001 I=1,IMAX F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1001 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 1015 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1015 CONTINUE DO 1019 K=2,L DO 1017 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1017 CONTINUE 1019 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1021 K=1,L DO 1021 I=1,IMAX FAC1(I,K)=ACOMB(8)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(8)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 1021 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1053 K=1,L DO 1053 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,8)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 1053 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1061 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,8)-SORC(I,L,8))) 1061 CONTINUE DO 2061 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,8)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,8)-SORC(I,L,8)) 2061 CONTINUE C C-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1101 K=1,L DO 1101 I=1,IMAX F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1101 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 1115 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1115 CONTINUE DO 1119 K=2,L DO 1117 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1117 CONTINUE 1119 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1121 K=1,L DO 1121 I=1,IMAX FAC1(I,K)=ACOMB(9)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 1121 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1153 K=1,L DO 1153 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,9)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 1153 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1161 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,9)-SORC(I,L,9))) 1161 CONTINUE DO 2161 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,9)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,9)-SORC(I,L,9)) 2161 CONTINUE C C-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1201 K=1,L DO 1201 I=1,IMAX F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1201 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 1215 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1215 CONTINUE DO 1219 K=2,L DO 1217 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1217 CONTINUE 1219 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1221 K=1,L DO 1221 I=1,IMAX FAC1(I,K)=ACOMB(10)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 1221 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1253 K=1,L DO 1253 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,10)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 1253 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1261 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,10)-SORC(I,L,10))) 1261 CONTINUE DO 3261 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,10)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,10)-SORC(I,L,10)) 3261 CONTINUE C C-----CALCULATION FOR BAND 11 (800-900 CM-1) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1301 K=1,L DO 1301 I=1,IMAX F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1301 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 1315 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1315 CONTINUE DO 1319 K=2,L DO 1317 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1317 CONTINUE 1319 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1321 K=1,L DO 1321 I=1,IMAX FAC1(I,K)=ACOMB(11)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(11)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 1321 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1353 K=1,L DO 1353 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,11)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 1353 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1361 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,11)-SORC(I,L,11))) 1361 CONTINUE DO 3361 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,11)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,11)-SORC(I,L,11)) 3361 CONTINUE C C-----CALCULATION FOR BAND 12 (900-990 CM-1) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1401 K=1,L DO 1401 I=1,IMAX F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1401 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 1415 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1415 CONTINUE DO 1419 K=2,L DO 1417 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1417 CONTINUE 1419 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1421 K=1,L DO 1421 I=1,IMAX FAC1(I,K)=ACOMB(12)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(12)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 1421 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1453 K=1,L DO 1453 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,12)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 1453 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1461 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,12)-SORC(I,L,12))) 1461 CONTINUE DO 3461 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,12)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,12)-SORC(I,L,12)) 3461 CONTINUE C C-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3)) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1501 K=1,L DO 1501 I=1,IMAX F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1501 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 1515 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1515 CONTINUE DO 1519 K=2,L DO 1517 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1517 CONTINUE 1519 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1521 K=1,L DO 1521 I=1,IMAX FAC1(I,K)=ACOMB(13)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(13)*TOTVO2(I,K+1)*SKO2D +TO3SPC(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 1521 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1553 K=1,L DO 1553 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,13)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 1553 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1561 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,13)-SORC(I,L,13))) 1561 CONTINUE DO 3561 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,13)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,13)-SORC(I,L,13)) 3561 CONTINUE C C-----CALCULATION FOR BAND 14 (1070-1200 CM-1) C C C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1601 K=1,L DO 1601 I=1,IMAX F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1601 CONTINUE C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE C P(K) (TOPM,TOPPHI) DO 1615 I=1,IMAX TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1615 CONTINUE DO 1619 K=2,L DO 1617 I=1,IMAX TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1617 CONTINUE 1619 CONTINUE C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1621 K=1,L DO 1621 I=1,IMAX FAC1(I,K)=ACOMB(14)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ 1 BETACM(14)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) CTMP0(I,K+1)=TT(I,K) 1621 CONTINUE C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1653 K=1,L DO 1653 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* 1 (CTMP(I,K+1)-CTMP(I,K)) EXCTS0(I,K)=EXCTS0(I,K)+SORC(I,K,14)* 1 (CTMP0(I,K+1)-CTMP0(I,K)) 1653 CONTINUE C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1661 I=1,IMAX GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,14)-SORC(I,L,14))) 1661 CONTINUE DO 3661 I=1,IMAX GXCTS0(I)=GXCTS0(I)+TT(I,L)*SORC(I,L,14)+ 1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + 2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * 3 (SORC(I,LP1,14)-SORC(I,L,14)) 3661 CONTINUE C C C OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND C USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE C THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT C BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS C REDUCING COMPUTATIONS! DO 1731 K=1,L DO 1731 I=1,IMAX GXCTS(I)=GXCTS(I)-EXCTS(I,K) GXCTS0(I)=GXCTS0(I)-EXCTS0(I,K) 1731 CONTINUE C C NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE C FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON) DO 1741 K=1,L DO 1741 I=1,IMAX EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K) EXCTS0(I,K)=EXCTS0(I,K)*RADCON*DELP(I,K) 1741 CONTINUE C---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT C EXCTS HAS ITS APPROPRIATE VALUE. C C*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS C (CTSO3) DO 1711 K=1,L DO 1711 I=1,IMAX CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1) CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1) CTMP20(I,K+1)=CO2SP(I,K+1) CTMP30(I,K+1)=TO3SP(I,K) 1711 CONTINUE DO 1701 K=1,L DO 1701 I=1,IMAX CTSO3(I,K)=RADCON*DELP(I,K)* 1 (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + 2 SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K))) 1701 CONTINUE DO 3701 K=1,L DO 3701 I=1,IMAX CTSO30(I,K)=RADCON*DELP(I,K)* 1 (CSOUR(I,K)*(CTMP20(I,K+1)-CTMP20(I,K)) + 2 SORC(I,K,13)*(CTMP30(I,K+1)-CTMP30(I,K))) 3701 CONTINUE RETURN END SUBROUTINE SWR93SIB(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL, 1 PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3, CFE932 NCLDS,KTOPSW,KBTMSW,CIRAB,CIRRF,CUVRF,CAMT, 2 NCLDS,KTOP,KBTM,CAMT,CRR,CTT, A ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND) CFPP$ NOCONCUR R C===> ********************************************************* C --- SWR91SIB --- MODIFIED FROM SWR89-BAND12....YUTAI HOU C --- SWR93SIB --- MODIFIED FROM SWR91SIB AS NOTED BELOW.. C -INPUTS 12 BANDS CLD REFLECTANCE AND TRANSMITANCE C -CRR,CTT TO REPLACE CIRAB,CIRRF,CUVRF...YUTAI HOU ..FEB 93 C C -SW- RADIATION CODE............................ C INPUTS:PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3,NCLDS, CDE93 KTOPSW,KBTMSW,CIRAB,CIRRF,CUVRF,CAMT, C KTOP,KBTM,CAMT,CRR,CTT, C ALVB,ALVD,ALNB,ALND; C OUTPUT:FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL, C GDFVB,GDFVD,GDFNB,GDFND. C --- SWR91SIB --- MODIFIED BY K. CAMPANA..06 MAR 92 C INCLUDE HPCON,PARMC CHANGED TO HCON,RDPARM C 6 Q..... VARIABLE NAMES RESTORED TO ORIGINAL 7,8 CHAR C CHANGE O3DIFF,DIFFCC TO O3DIFCTR,DIFFCTR C --- SWR91SIB --- MODIFIED BY Y. HOU FEB 93 C INPUTS 12 BANDS CLD REFLECTTANCE AND TRANSMITTANCE C CRR,CTT TO REPLACE CIRAB,CIRRF,CUVRF C --- SWR93SIB --- MODIFIED BY Y. HOU DEC 93 C INPUT VARIABLES KTOP, KBTM C --- --- MODIFIED BY Y. HOU FEB 94 C TO INCORPORATE B KATZ IMPROVED CODING C C===> ********************************************************* COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NB IS A SHORTWAVE PARAMETER; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. C --- VARIABLES AS IN ARGUMENT LIST D I M E N S I O N CFE931 FSWC (IMBX,LP1), HSWC (IMBX,LP1) CFE932, FSWL (IMBX,LP1), HSWL (IMBX,LP1) 1 FSWC (IMBX,LP1), HSWC (IMBX,LP1), CRR (IMBX,NB,LP1) 2, FSWL (IMBX,LP1), HSWL (IMBX,LP1), CTT (IMBX,NB,LP1) 3, UFSWC (IMBX,LP1), DFSWC (IMBX,LP1) 4, UFSWL (IMBX,LP1), DFSWL (IMBX,LP1) 5, PRESS (IMBX,LP1), RH2O (IMBX,L), QO3 (IMBX,L) 6, CAMT (IMBX,LP1), KTOP (IMBX,LP1), KBTM (IMBX,LP1) CFE937, CIRAB (IMBX,LP1), CIRRF (IMBX,LP1), CUVRF (IMBX,LP1) 8, COSZRO(IMAX), TAUDAR(IMAX), NCLDS (IMAX) A, ALVB (IMAX), ALNB (IMAX), ALVD (IMAX), ALND (IMAX) B, GDFVB (IMAX), GDFNB (IMAX), GDFVD (IMAX), GDFND (IMAX) C --- LOCAL VARIABLES D I M E N S I O N 1 PP (IMBX,LP1), DP (IMBX,LP1), PR2 (IMBX,LP1) 3, DU (IMBX,LP1), DUCO2 (IMBX,LP1), DUO3 (IMBX,LP1) 4, FF (IMBX,LP1), FFCO2 (IMBX,LP1), FFO3 (IMBX,LP1) 5, RRAY (IMAX), DFNTOP(IMBX,NB), SECZ (IMAX) 6, REFL (IMAX), TEMP1 (IMAX), REFL2 (IMAX) 7, TEMPF (IMAX), TEMPG (IMAX) A, CCMAX (IMAX), XAMT (IMBX,LP1), KBTMSW(IMBX,LP1) D I M E N S I O N 1 UD (IMBX,LP1), UR (IMBX,LP1) 2, UCO2 (IMBX,LLP2), UDCO2 (IMBX,LP1), URCO2 (IMBX,LP1) 3, UO3 (IMBX,LLP2), UDO3 (IMBX,LP1), URO3 (IMBX,LP1) 4, TCO2 (IMBX,LLP2), TDCO2 (IMBX,LP1), TUCO2 (IMBX,LP1) 5, TO3 (IMBX,LLP2), TDO3 (IMBX,LP1), TUO3 (IMBX,LP1) D I M E N S I O N 1 DFN (IMBX,LP1), UFN (IMBX,LP1), CR (IMBX,LP1) 2, TTD (IMBX,LP1), TTU (IMBX,LP1), CT (IMBX,LP1) 3, PPTOP (IMBX,LP1), DPCLD (IMBX,LP1) D I M E N S I O N 1 MNKBTM(LP1) , MNKTOP(LP1) , MXKBTM(LP1) 2, MXKTOP(LP1) L O G I C A L 1 LSAVE(IMAX),LSAVE0(IMBX,LP1),LSAVE1(IMBX,LP1,LP1) 2, LSAVE2(IMBX,LP1,LP1) C --- EQUIVALENCED LOCAL VARIABLES D I M E N S I O N 1 TTUB1 (IMBX,LP1), TUCL1 (IMBX,LP1) 2, TTDB1 (IMBX,LP1), TDCL1 (IMBX,LP1), TDCL2 (IMBX,LP1) 3, UFNTRN(IMBX,LP1), UFNCLU(IMBX,LP1), TCLU (IMBX,LP1) 4, DFNTRN(IMBX,LP1), DFNCLU(IMBX,LP1), TCLD (IMBX,LP1) 5, ALFA (IMBX,LP1), ALFAU (IMBX,LP1) E Q U I V A L E N C E 1 (UDO3 , UO3 (1,1), DFNCLU), (URO3 , UO3 (1,LP2), UFNCLU) 2, (UDCO2, UCO2(1,1), TCLD ), (URCO2, UCO2(1,LP2), TCLU ) 3, (TDO3 , TO3 (1,1), DFNTRN), (TUO3 , TO3 (1,LP2), UFNTRN) 4, (TDCO2, TCO2(1,1) ), (TUCO2, TCO2(1,LP2) ) 5, (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) 6, (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) 7, (PR2 , TDCL2) C C---COMMON FOR LOCAL DATA VARIABLES--- COMMON /SWRSAV/ ABCFF(NB),PWTS(NB),CFCO2,CFO3,REFLO3,RRAYAV C D A T A C 1 ABCFF / 2*4.0E-5, 0.002, 0.035, 0.377, 1.95, 9.40, 44.6, C 1 190.0, 989.0, 2706.0, 39011.0 / C 2, PWTS / 0.5000, 0.121416, 0.0698, 0.1558, 0.0631, 0.0362, C 2 0.0243, 0.0158, 0.0087, 0.001467, 0.002342, 0.001075 / C 3, CFCO2, CFO3, REFLO3, RRAYAV / 508.96, 466.64, 1.9, 0.144 / C 1 ABCFF / 2*4.0E-5, .002, .035, .377, 1.95, 9.40, 44.6, 190. / C 2, PWTS /.5000,.1470,.698,.1443,.0584,.0335,.0225,.0158,.0087/ C 3, CFCO2, CFO3, REFLO3, RRAYAV / 508.96, 466.64, 1.9, 0.144 / C C CALCULATE SECANT OF ZENITH ANGLE (SECZ),FLUX PRESSURES(PP), C LAYER WIDTH (DP) AND PRESSURE SCALING FACTOR (PR2). DO 100 I=1,IMAX SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE) PP(I,1) = ZERO PP(I,LP1) = PRESS(I,LP1) TEMP1(I) = ONE/PRESS(I,LP1) 100 CONTINUE DO 110 K=2,L DO 110 I=1,IMAX PP(I,K) = HAF*(PRESS(I,K)+PRESS(I,K-1)) 110 CONTINUE DO 120 K=1,L DO 120 I=1,IMAX DP (I,K) = PP(I,K+1)-PP(I,K) PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1)) 120 CONTINUE DO 130 K=1,L DO 130 I=1,IMAX PR2(I,K) = PR2(I,K)*TEMP1(I) 130 CONTINUE C CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS) DO 140 N=1,NB DO 140 IP=1,IMAX DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N) 140 CONTINUE C EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION C FOR THE VISIBLE BAND DO 150 I=1,IMAX RRAY(I) = HP219/(ONE+HP816*COSZRO(I)) REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ 1 (ONE-ALVD(I)*RRAYAV) 150 CONTINUE DO 155 I=1,IMAX RRAY(I) = 0.104/(ONE+4.8*COSZRO(I)) REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ 1 (ONE-ALVD(I)*0.093) 155 CONTINUE C CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER C IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2. C DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3. DO 160 K=1,L DO 160 I=1,IMAX DU (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K) DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K) DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K) 160 CONTINUE C............... CALCULATE CLEAR SKY SW FLUX C OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE C FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD C PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING C QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3. DO 200 IP=1,IMAX UD (IP,1) = ZERO UDCO2(IP,1) = ZERO UDO3 (IP,1) = ZERO 200 CONTINUE DO 210 K=2,LP1 DO 210 I=1,IMAX UD (I,K) = UD (I,K-1)+DU (I,K-1)*SECZ(I) UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I) UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I) 210 CONTINUE DO 220 IP=1,IMAX UR (IP,LP1) = UD (IP,LP1) URCO2(IP,LP1) = UDCO2(IP,LP1) URO3 (IP,LP1) = UDO3 (IP,LP1) 220 CONTINUE DO 230 K=L,1,-1 DO 230 IP=1,IMAX UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR 230 CONTINUE C CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED C BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED C BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX, C AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT C OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2. C SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE C VALUES ACTUALLY STORED IN TCO2. DO 240 K=2,LL+1 DO 240 I=1,IMAX TCO2(I,K) = ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K)+H129M2)) 1 -H75826M4) 240 CONTINUE C NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN C THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS C 50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED C BY 2. THE TRANSMISSIONS ARE STORED IN TO3. HTEMP = H1036E2*H1036E2*H1036E2 DO 250 K=2,LL+1 DO 250 I=1,IMAX TO3(I,K) = ONE - TWO*UO3(I,K)* 1 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K)))+ 2 H658M2/(ONE+HTEMP*UO3(I,K)*UO3(I,K)*UO3(I,K))+ 3 H2118M2/(ONE+UO3(I,K)*(H42M2+H323M4*UO3(I,K)))) 250 CONTINUE C START FREQUENCY LOOP (ON N) HERE C C--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION DO 260 K=1,L DO 260 I=1,IMAX TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1))) TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K))) DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1) UFN(I,K) = TTU(I,K)*TUO3(I,K) 260 CONTINUE DO 270 I=1,IMAX DFN(I,1) = ONE UFN(I,LP1) = DFN(I,LP1) 270 CONTINUE C SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE C ATMOSPHERE (DFNTOP(I,1)) C DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS DO 280 K=1,LP1 DO 280 I=1,IMAX DFSWL(I,K) = DFN(I,K)*DFNTOP(I,1) UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1) 280 CONTINUE DO 285 I=1,IMAX GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I)) GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - 1 (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I)) GDFNB(I) = ZERO GDFND(I) = ZERO 285 CONTINUE C---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME C AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND C TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS C RAYLEIGH SCATTERING NEED NOT BE CONSIDERED. DO 350 N=2,NB IF (N.EQ.2) THEN C THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO C THAT OF BAND 1 (SAVED AS TTD,TTU) C--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION DO 290 K=1,L DO 290 I=1,IMAX DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1) UFN(I,K) = TTU(I,K)*TUCO2(I,K) 290 CONTINUE ELSE C CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED C BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH C IS THE SAME FOR ALL INFRARED BANDS. DO 300 K=1,L DO 300 I=1,IMAX DFN(I,K+1)= & EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1)))*TDCO2(I,K+1) UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K)))*TUCO2(I,K) 300 CONTINUE ENDIF C---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR C ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS. DO 310 I=1,IMAX DFN(I,1) = ONE UFN(I,LP1) = DFN(I,LP1) 310 CONTINUE C SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP C AND SUM OVER BANDS DO 320 K=1,LP1 DO 320 I=1,IMAX DFSWL(I,K) = DFSWL(I,K) + DFN(I,K)*DFNTOP(I,N) UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N) 320 CONTINUE DO 330 I=1,IMAX GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N) 330 CONTINUE 350 CONTINUE DO 360 K=1,LP1 DO 360 I=1,IMAX FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K) 360 CONTINUE DO 370 K=1,L DO 370 I=1,IMAX HSWL(I,K) = RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K) 370 CONTINUE C C---END OF FREQUENCY LOOP (OVER N) C.................CALCULATE CLOUDY SKY SW FLUX KCLDS=NCLDS(1) MAXKTP=KTOP(1,NCLDS(1)+1) CDE93 MAXKTP=KTOPSW(1,NCLDS(1)+1) DO 400 I=2,IMAX KCLDS=MAX(NCLDS(I),KCLDS) MAXKTP=MAX(KTOP(I,NCLDS(I)+1),MAXKTP) CDE93 MAXKTP=MAX(KTOPSW(I,NCLDS(I)+1),MAXKTP) 400 CONTINUE IF (KCLDS .EQ. 0) THEN DO 410 K=1,LP1 DO 410 I=1,IMAX DFSWC(I,K) = DFSWL(I,K) UFSWC(I,K) = UFSWL(I,K) FSWC (I,K) = FSWL (I,K) 410 CONTINUE DO 420 K=1,L DO 420 I=1,IMAX HSWC(I,K) = HSWL(I,K) 420 CONTINUE RETURN END IF DO 430 K=1,LP1 DO 430 I=1,IMAX XAMT(I,K) = CAMT(I,K) KBTMSW(I,K) = KBTM(I,K) 430 CONTINUE DO 440 K=2,KCLDS+1 DO 440 I=1,IMAX IF (CAMT(I,K).GT.ZERO) KBTMSW(I,K) = KBTMSW(I,K) + 1 440 CONTINUE DO 445 I=1,IMAX IF(NCLDS(I).LE.0) THEN CCMAX(I) = ZERO ELSE CCMAX(I) = ONE ENDIF 445 CONTINUE DO 450 K=1,KCLDS DO 450 I=1,IMAX IF(K.LE.NCLDS(I)) THEN CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1)) ENDIF 450 CONTINUE DO 455 I=1,IMAX IF(NCLDS(I).GT.0) CCMAX(I) = ONE - CCMAX(I) 455 CONTINUE DO 460 K=1,KCLDS DO 460 I=1,IMAX IF(K.LE.NCLDS(I) .AND. CCMAX(I).GT.ZERO) THEN XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I) ENDIF 460 CONTINUE C DO 470 I=1,IMAX C NNCLDS = NCLDS(I) C CCMAX(I) = ZERO C IF (NNCLDS .LE. 0) GO TO 470 C DO 450 K=1,NNCLDS C CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1)) C450 CONTINUE C CCMAX(I) = ONE - CCMAX(I) C IF (CCMAX(I) .GT. ZERO) THEN C DO 460 K=1,NNCLDS C XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I) C460 CONTINUE C END IF C470 CONTINUE DO 480 K=1,LP1 DO 480 I=1,IMAX FF (I,K) = DIFFCTR FFCO2(I,K) = DIFFCTR FFO3 (I,K) = O3DIFCTR 480 CONTINUE DO 490 K=1,MAXKTP DO 490 IP=1,IMAX CDE93 IF(K.LE.KTOPSW(IP,NCLDS(IP)+1)) THEN IF(K.LE.KTOP(IP,NCLDS(IP)+1)) THEN FF (IP,K) = SECZ(IP) FFCO2(IP,K) = SECZ(IP) FFO3 (IP,K) = SECZ(IP) ENDIF 490 CONTINUE C DO 490 IP=1,IMAX CDE93 JTOP = KTOPSW(IP,NCLDS(IP)+1) C JTOP = KTOP(IP,NCLDS(IP)+1) C DO 490 K=1,JTOP C FF (IP,K) = SECZ(IP) C FFCO2(IP,K) = SECZ(IP) C FFO3 (IP,K) = SECZ(IP) C490 CONTINUE DO 500 I=1,IMAX RRAY(I) = HP219/(ONE+HP816*COSZRO(I)) REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ 1 (ONE-ALVD(I)*RRAYAV) 500 CONTINUE DO 510 IP=1,IMAX UD (IP,1) = ZERO UDCO2(IP,1) = ZERO UDO3 (IP,1) = ZERO 510 CONTINUE DO 520 K=2,LP1 DO 520 I=1,IMAX UD (I,K) = UD (I,K-1)+DU (I,K-1)*FF (I,K) UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K) UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K) 520 CONTINUE DO 530 IP=1,IMAX UR (IP,LP1) = UD (IP,LP1) URCO2(IP,LP1) = UDCO2(IP,LP1) URO3 (IP,LP1) = UDO3 (IP,LP1) 530 CONTINUE DO 540 K=L,1,-1 DO 540 IP=1,IMAX UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR 540 CONTINUE DO 550 K=2,LL+1 DO 550 I=1,IMAX TCO2(I,K) = ONE - TWO*(H235M3 * EXP(HP26*LOG(UCO2(I,K)+H129M2)) 1 -H75826M4) 550 CONTINUE DO 560 K=2,LL+1 DO 560 I=1,IMAX TO3(I,K) = ONE - TWO*UO3(I,K)* 1 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K)))+ 2 H658M2/(ONE+HTEMP*UO3(I,K)*UO3(I,K)*UO3(I,K))+ 3 H2118M2/(ONE+UO3(I,K)*(H42M2+H323M4*UO3(I,K)))) 560 CONTINUE C******************************************************************** C---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN C BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!). C******************************************************************** DO 570 I=1,IMAX CR(I,1) = REFL(I) 570 CONTINUE C***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR C REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND C---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES C EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE). DO 580 KK=2,KCLDS+1 DO 580 I=1,IMAX CFE93 CR(I,KK) = CUVRF(I,KK)*XAMT(I,KK) CFE93 CT(I,KK) = ONE-CR(I,KK) CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK) CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK) 580 CONTINUE C---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF C "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED C LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL C FREQUENCY BANDS. DO 590 KK=1,KCLDS DO 590 I=1,IMAX CDE93 IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN IF ((KBTM(I,KK+1)).GT.KTOP(I,KK+1)) THEN CDE93 PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1)) PPTOP(I,KK)=PP(I,KTOP(I,KK+1)) DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1))) ENDIF 590 CONTINUE DO 600 K=1,L DO 600 I=1,IMAX TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1))) TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K))) TTD (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1) TTU (I,K) = TTUB1(I,K)*TUO3(I,K) 600 CONTINUE DO 610 I=1,IMAX TTD(I,1) = ONE TTU(I,LP1) = TTD(I,LP1) 610 CONTINUE C***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT C TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR C EACH BAND N. THE REQUIRED QUANTITIES ARE: C TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: C TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: C TTD(I,KBTMSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: C AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE C STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY, C AS THEY HAVE MULTIPLE USE IN THE PGM. C---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN: DO 620 I=1,IMAX TDCL1 (I,1) = TTD(I,LP1) TUCL1 (I,1) = TTU(I,LP1) TDCL2 (I,1) = TDCL1(I,1) DFNTRN(I,1) = ONE/TDCL1(I,1) UFNTRN(I,1) = DFNTRN(I,1) 620 CONTINUE DO 630 KK=2,KCLDS+1 DO 630 I=1,IMAX CDE93 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK)) CDE93 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK)) TDCL1(I,KK) = TTD(I,KTOP(I,KK)) TUCL1(I,KK) = TTU(I,KTOP(I,KK)) TDCL2(I,KK) = TTD(I,KBTMSW(I,KK)) 630 CONTINUE C---COMPUTE INVERSES DO 640 K=1,KCLDS DO 640 I=1,IMAX DFNTRN(I,K+1) = ONE/TDCL1(I,K+1) UFNTRN(I,K+1) = ONE/TUCL1(I,K+1) 640 CONTINUE C---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE C TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS C QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY C FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH C ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K). DO 650 K=1,KCLDS DO 650 I=1,IMAX TCLU(I,K) = TDCL1(I,K)*DFNTRN(I,K+1)*CT(I,K+1) TCLD(I,K) = TDCL1(I,K)/TDCL2(I,K+1) 650 CONTINUE C***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION C COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE C FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW C THE CLOUD IN QUESTION. C---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION DO 660 I=1,IMAX ALFA (I,1)=CR(I,1) ALFAU(I,1)=ZERO 660 CONTINUE C---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER! DO 670 KK=2,KCLDS+1 DO 670 I=1,IMAX ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ 1 (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK)) ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK) 670 CONTINUE C CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS C---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP C OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX C AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST C CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE C HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU C EQUALS ALFA. THIS IS ALSO CORRECT. CKZ DO 680 I=1,IMAX DO 680 KK=KCLDS,1,-1 DO 680 I=1,IMAX IF(KK.GE.NCLDS(I)) THEN UFNCLU(I,KK+1) = ALFA(I,KK+1)*TDCL1(I,KK+1) DFNCLU(I,KK+1) = TDCL1(I,KK+1) END IF 680 CONTINUE C---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED C ABOVE CKZ DO 690 KK=KCLDS,1,-1 DO 690 KK=KCLDS,2,-1 DO 690 I=1,IMAX IF(KK.LE.NCLDS(I)) THEN UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* 1 TCLU(I,KK)) DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK) END IF 690 CONTINUE CKZ DO 695 I=1,IMAX UFNCLU(I,1) = UFNCLU(I,2)*ALFAU(I,2)/(ALFA(I,2)*TCLU(I,1)) DFNCLU(I,1) = UFNCLU(I,1)/ALFA(I,1) 695 CONTINUE DO 700 K=1,KCLDS+1 DO 700 I=1,IMAX UFNTRN(I,K) = UFNCLU(I,K)*UFNTRN(I,K) DFNTRN(I,K) = DFNCLU(I,K)*DFNTRN(I,K) 700 CONTINUE C---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD) MNKBOT = KBTMSW(1,2) DO 710 I=2,IMAX MNKBOT = MIN(KBTMSW(I,2),MNKBOT) 710 CONTINUE DO 720 K=MNKBOT,LP1 DO 720 I=1,IMAX LSAVE0(I,K) = K.GE.KBTMSW(I,2) IF(LSAVE0(I,K)) THEN UFN(I,K) = UFNTRN(I,1)*TTU(I,K) DFN(I,K) = DFNTRN(I,1)*TTD(I,K) ENDIF 720 CONTINUE C DO 720 I=1,IMAX C J2=KBTMSW(I,2) C DO 710 K=J2,LP1 C UFN(I,K) = UFNTRN(I,1)*TTU(I,K) C DFN(I,K) = DFNTRN(I,1)*TTD(I,K) C710 CONTINUE C720 CONTINUE C---REMAINING LEVELS (IF ANY!) DO 760 KK=2,KCLDS+1 CDE93 MXKTOP(KK) = KTOPSW(1,KK) MXKTOP(KK) = KTOP(1,KK) MNKBTM(KK+1) = KBTMSW(1,KK+1) CDE93 MNKTOP(KK) = KTOPSW(1,KK) MNKTOP(KK) = KTOP(1,KK) MXKBTM(KK) = KBTMSW(1,KK) DO 725 I=2,IMAX CDE93 MXKTOP(KK) = MAX(KTOPSW(I,KK),MXKTOP(KK)) MXKTOP(KK) = MAX(KTOP(I,KK),MXKTOP(KK)) MNKBTM(KK+1) = MIN(KBTMSW(I,KK+1),MNKBTM(KK+1)) CDE93 MNKTOP(KK) = MIN(KTOPSW(I,KK),MNKTOP(KK)) MNKTOP(KK) = MIN(KTOP(I,KK),MNKTOP(KK)) MXKBTM(KK) = MAX(KBTMSW(I,KK),MXKBTM(KK)) 725 CONTINUE DO 730 I=1,IMAX CDE93 LSAVE(I) = KTOPSW(I,KK).GT.1 LSAVE(I) = KTOP(I,KK).GT.1 730 CONTINUE DO 740 K=MNKBTM(KK+1),MXKTOP(KK) DO 740 I=1,IMAX LSAVE1(I,K,KK) = K.GE.KBTMSW(I,KK+1) .AND. 1 K.LE.KTOP(I,KK) .AND. LSAVE(I) CDE931 K.LE.KTOPSW(I,KK) .AND. LSAVE(I) IF(LSAVE1(I,K,KK)) THEN UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) ENDIF 740 CONTINUE C---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD C LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY C TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX). DO 745 I=1,IMAX IF ((KBTM(I,KK)).GT.KTOP(I,KK)) THEN TEMPF(I) = (UFNCLU(I,KK)-UFN(I,KBTMSW(I,KK)))*DPCLD(I,KK-1) TEMPG(I) = (DFNCLU(I,KK)-DFN(I,KBTMSW(I,KK)))*DPCLD(I,KK-1) ENDIF 745 CONTINUE DO 750 K=MNKTOP(KK)+1,MXKBTM(KK)-1 DO 750 I=1,IMAX CDE93 LSAVE2(I,K,KK) = K.GT.KTOPSW(I,KK) .AND. LSAVE2(I,K,KK) = K.GT.KTOP(I,KK) .AND. 1 K.LT.KBTMSW(I,KK) .AND. LSAVE(I) IF(LSAVE2(I,K,KK)) THEN UFN(I,K) = UFNCLU(I,KK)+TEMPF(I)*(PP(I,K)-PPTOP(I,KK-1)) DFN(I,K) = DFNCLU(I,KK)+TEMPG(I)*(PP(I,K)-PPTOP(I,KK-1)) ENDIF 750 CONTINUE 760 CONTINUE C DO 760 KK=2,KCLDS+1 C DO 755 I=1,IMAX CDE93 J1=KTOPSW(I,KK) C J1=KTOP(I,KK) C J2=KBTMSW(I,KK+1) C IF (J1.EQ.1) GO TO 755 C DO 730 K=J2,J1 C UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) C DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) C730 CONTINUE C---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD C LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY C TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX). C J3=KBTMSW(I,KK) C IF ((J3-J1).GT.1) THEN C TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1) C TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1) C DO 740 K=J1+1,J3-1 C UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1)) C DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1)) C740 CONTINUE C ENDIF C755 CONTINUE C760 CONTINUE DO 770 K=1,LP1 DO 770 I=1,IMAX DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1) UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1) 770 CONTINUE DO 780 I=1,IMAX TEMP1(I) = ONE - CCMAX(I) GDFVB(I) = TEMP1(I)*GDFVB(I) GDFNB(I) = TEMP1(I)*GDFNB(I) GDFVD(I) = TEMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1) 780 CONTINUE C---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME C AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND C TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS C RAYLEIGH SCATTERING NEED NOT BE CONSIDERED. CFE93 DO 790 I=1,IMAX*(KCLDS+1) CFE93 CR(I,1) = CIRRF(I,1)*XAMT(I,1) CFE93 CT(I,1) = ONE-XAMT(I,1)*(CIRRF(I,1)+CIRAB(I,1)) C90 CONTINUE C DO 1000 N=2,NB CFE93 DO 790 K=1,KCLDS+1 DO 790 I=1,IMAX CR(I,K) = CRR(I,N,K)*XAMT(I,K) CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K) 790 CONTINUE CFE93 IF (N.EQ.2) THEN C THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO C THAT OF BAND 1 (SAVED AS TTDB1,TTUB1) DO 800 K=1,L DO 800 I=1,IMAX TTD(I,K+1) = TTDB1(I,K+1)*TDCO2(I,K+1) TTU(I,K) = TTUB1(I,K)*TUCO2(I,K) 800 CONTINUE ELSE DO 810 K=1,L DO 810 I=1,IMAX TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) 1 * TDCO2(I,K+1) TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) 1 * TUCO2(I,K) 810 CONTINUE ENDIF C---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR C ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS. DO 820 I=1,IMAX TTU(I,LP1) = TTD(I,LP1) TTD(I,1) = ONE 820 CONTINUE C***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT C TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR C EACH BAND N. THE REQUIRED QUANTITIES ARE: C TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: C TTD(I,KBTMSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+1: C TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: C AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED C IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS C THEY HAVE MULTIPLE USE IN THE PGM. C---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN: DO 830 I=1,IMAX TDCL1 (I,1) = TTD(I,LP1) TUCL1 (I,1) = TTU(I,LP1) TDCL2 (I,1) = TDCL1(I,1) DFNTRN(I,1) = ONE/TDCL1(I,1) UFNTRN(I,1) = DFNTRN(I,1) 830 CONTINUE DO 840 KK=2,KCLDS+1 DO 840 I=1,IMAX CDE93 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK)) CDE93 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK)) TDCL1(I,KK) = TTD(I,KTOP(I,KK)) TUCL1(I,KK) = TTU(I,KTOP(I,KK)) TDCL2(I,KK) = TTD(I,KBTMSW(I,KK)) 840 CONTINUE DO 850 K=1,KCLDS DO 850 I=1,IMAX DFNTRN(I,K+1) = ONE/TDCL1(I,K+1) UFNTRN(I,K+1) = ONE/TUCL1(I,K+1) 850 CONTINUE DO 860 K=1,KCLDS DO 860 I=1,IMAX TCLU(I,K) = TDCL1(I,K)*DFNTRN(I,K+1)*CT(I,K+1) TCLD(I,K) = TDCL1(I,K)/TDCL2(I,K+1) 860 CONTINUE C***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION C COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE C FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW C THE CLOUD IN QUESTION. DO 870 I=1,IMAX ALFA (I,1) = CR(I,1) ALFAU(I,1) = ZERO 870 CONTINUE C---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER! DO 880 KK=2,KCLDS+1 DO 880 I=1,IMAX ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - 1 TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK)) ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK) 880 CONTINUE C CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS C---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP C OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX C AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST C CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE C HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU C EQUALS ALFA. THIS IS ALSO CORRECT. CKZ DO 890 I=1,IMAX DO 890 KK=KCLDS,1,-1 DO 890 I=1,IMAX IF(KK.GE.NCLDS(I)) THEN UFNCLU(I,KK+1) = ALFA(I,KK+1)*TDCL1(I,KK+1) DFNCLU(I,KK+1) = TDCL1(I,KK+1) END IF 890 CONTINUE CKZ DO 900 KK=KCLDS,1,-1 DO 900 KK=KCLDS,2,-1 DO 900 I=1,IMAX IF(KK.LE.NCLDS(I)) THEN UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* 1 TCLU(I,KK)) DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK) END IF 900 CONTINUE CKZ DO 905 I=1,IMAX UFNCLU(I,1) = UFNCLU(I,2)*ALFAU(I,2)/(ALFA(I,2)*TCLU(I,1)) DFNCLU(I,1) = UFNCLU(I,1)/ALFA(I,1) 905 CONTINUE C NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS C C NOTE THAT MNKBOT, MNKBTM, MXKTOP, MNKTOP, MXKBTM, LSAVE1, AND C LSAVE2 WERE ALL SAVED WHEN CALCULATED FOR BAND NO. 1 ! C THEY DO NOT CHANGE HERE FOR THE CALCULATION OF BANDS 2-12 ! C DO 910 K=1,KCLDS+1 DO 910 I=1,IMAX UFNTRN(I,K) = UFNCLU(I,K)*UFNTRN(I,K) DFNTRN(I,K) = DFNCLU(I,K)*DFNTRN(I,K) 910 CONTINUE DO 930 K=MNKBOT,LP1 DO 930 I=1,IMAX IF(LSAVE0(I,K)) THEN UFN(I,K) = UFNTRN(I,1)*TTU(I,K) DFN(I,K) = DFNTRN(I,1)*TTD(I,K) ENDIF 930 CONTINUE C DO 930 I=1,IMAX C J2 = KBTMSW(I,2) C DO 920 K=J2,LP1 C UFN(I,K) = UFNTRN(I,1)*TTU(I,K) C DFN(I,K) = DFNTRN(I,1)*TTD(I,K) C920 CONTINUE C930 CONTINUE DO 970 KK=2,KCLDS+1 DO 940 K=MNKBTM(KK+1),MXKTOP(KK) DO 940 I=1,IMAX IF(LSAVE1(I,K,KK)) THEN UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) ENDIF 940 CONTINUE DO 950 I=1,IMAX IF ((KBTM(I,KK)).GT.KTOP(I,KK)) THEN TEMPF(I)=(UFNCLU(I,KK)-UFN(I,KBTMSW(I,KK)))*DPCLD(I,KK-1) TEMPG(I)=(DFNCLU(I,KK)-DFN(I,KBTMSW(I,KK)))*DPCLD(I,KK-1) ENDIF 950 CONTINUE DO 960 K=MNKTOP(KK)+1,MXKBTM(KK)-1 DO 960 I=1,IMAX IF(LSAVE2(I,K,KK)) THEN UFN(I,K) = UFNCLU(I,KK)+TEMPF(I)*(PP(I,K)-PPTOP(I,KK-1)) DFN(I,K) = DFNCLU(I,KK)+TEMPG(I)*(PP(I,K)-PPTOP(I,KK-1)) ENDIF 960 CONTINUE 970 CONTINUE C DO 970 KK=2,KCLDS+1 C DO 965 I=1,IMAX CDE93 J1 = KTOPSW(I,KK) C J1 = KTOP(I,KK) C J2 = KBTMSW(I,KK+1) C IF (J1.EQ.1) GO TO 965 C DO 940 K=J2,J1 C UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) C DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) C940 CONTINUE C J3 = KBTMSW(I,KK) C IF ((J3-J1).GT.1) THEN C TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1) C TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1) C DO 950 K=J1+1,J3-1 C UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1)) C DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1)) C950 CONTINUE C ENDIF C965 CONTINUE C970 CONTINUE DO 980 K=1,LP1 DO 980 I=1,IMAX DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N) UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N) 980 CONTINUE DO 990 I=1,IMAX GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N) 990 CONTINUE 1000 CONTINUE DO 1100 K=1,LP1 DO 1100 I=1,IMAX DFSWC(I,K) = TEMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K) UFSWC(I,K) = TEMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K) 1100 CONTINUE DO 1200 K=1,LP1 DO 1200 I=1,IMAX FSWC(I,K) = UFSWC(I,K)-DFSWC(I,K) 1200 CONTINUE DO 1250 K=1,L DO 1250 I=1,IMAX HSWC(I,K) = RADCON*(FSWC(I,K+1)-FSWC(I,K))/DP(I,K) 1250 CONTINUE RETURN END SUBROUTINE TABLE CFPP$ NOCONCUR R C SUBROUTINE TABLE COMPUTES TABLE ENTRIES USED IN THE LONGWAVE RADIA C PROGRAM. ALSO CALCULATED ARE INDICES USED IN STRIP-MINING AND FOR C SOME PRE-COMPUTABLE FUNCTIONS. C INPUTS: C OUTPUTS: C EM1,EM1WDE,TABLE1,TABLE2,TABLE3 TABCOM C EM3,SOURCE,DSRCE,IND,INDX2,KMAXV TABCOM C KMAXVM, TABCOM C AO3RND,BO3RND,AB15 BANDTA C AB15WD,SKC1R,SKO3R,SKO2D BDWIDE C COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0, * P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA COMMON/PHYCON/RATCO2MW,RATH2OMW COMMON/PHYCON/RADCON1 COMMON/PHYCON/GINV,P0INV,GP0INV COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE, * FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5, * H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3, * H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2, * H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8, * H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518, * HP369,HP1 COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4, * H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5, * H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7, * H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10, * H11M10,H1M10,H83M11,H82M11,H8M11,H77M11, * H72M11,H53M11,H48M11,H44M11,H42M11,H37M11, * H35M11,H32M11,H3M11,H28M11,H24M11,H23M11, * H2M11,H18M11,H15M11,H14M11,H114M11,H11M11, * H1M11,H96M12,H93M12,H77M12,H74M12,H65M12, * H62M12,H6M12,H45M12,H44M12,H4M12,H38M12, * H37M12,H3M12,H29M12,H28M12,H24M12,H21M12, * H16M12,H14M12,H12M12,H8M13,H46M13,H36M13, * H135M13,H12M13,H1M13,H3M14,H15M14,H14M14, * H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23, * H1M24,H26M30,H14M30,H25M31,H21M31,H12M31, * H9M32,H55M32,H45M32,H4M33,H62M34,H1M60 COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2 COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666, * H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1, * H9P94,HP6,H625M2,HP228,HP60241,HM1797E1, * H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819 COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26, * H129M2,H75826M4,H1P082,HP805,H1386E2, * H658M2,H1036E2,H2118M2,H42M2,H323M4, * H67390E2,HP3795,HP5048,H102M5,H451M6 COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16, * HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3, * H6P08108,HMP805,HP602409,HP526315, * H28571M2,H1M16 COMMON/HCON/H3M4 COMMON/HCON/HM8E1 COMMON/HCON/H28E1 C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C COMMON BLOCK BANDTA CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING 10 CM-1 WIDE BANDS.THE 15 UM CO2 COMPLEX C IS 2 BANDS,560-670 AND 670-800 CM-1. OZONE COEFFICIENTS ARE C IN 3 BANDS,670-800 (14.1 UM),990-1070 AND 1070-1200 (9.6 UM). C THE (NBLW) BANDS NOW INCLUDE: C 56 BANDS, 10 CM-1 WIDE 0 - 560 CM-1 C 2 BANDS, 15 UM COMPLEX 560 - 670 CM-1 C 670 - 800 CM-1 C 3 "CONTINUUM" BANDS 800 - 900 CM-1 C 900 - 990 CM-1 C 1070 - 1200 CM-1 C 1 BAND FOR 9.6 UM BAND 990 - 1070 CM-1 C 100 BANDS, 10 CM-1 WIDE 1200 - 2200 CM-1 C 1 BAND FOR 4.3 UM SRC 2270 - 2380 CM-1 C THUS NBLW PRESENTLY EQUALS 163 C ALL BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C C ARNDM = RANDOM "A" PARAMETER FOR (NBLW) BANDS C BRNDM = RANDOM "B" PARAMETER FOR (NBLW) BANDS C BETAD = CONTINUUM COEFFICIENTS FOR (NBLW) BANDS C AP,BP = CAPPHI COEFFICIENTS FOR (NBLW) BANDS C ATP,BTP = CAPPSI COEFFICIENTS FOR (NBLW) BANDS C BANDLO = LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C BANDHI = HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS C AO3RND = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3RND = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15 = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C DATA FOR ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND ARE OBTAINED BY C USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS ARE FROM C ROBERTS (1976). COMMON / BANDTA / ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW), 1 BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW), 2 BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2) C C COMMON BLOCK BDWIDE CONTAINS RANDOM BAND PARAMETERS FOR SPECIFIC C WIDE BANDS. AT PRESENT,THE INFORMATION CONSISTS OF 1) RANDOM C MODEL PARAMETERS FOR THE 15 UM BAND,560-800 CM-1; 2) THE C CONTINUUM COEFFICIENT FOR THE 800-990,1070-1200 CM-1 BAND C SPECIFICALLY: C AWIDE = RANDOM "A" PARAMETER FOR BAND C BWIDE = RANDOM "B" PARAMETER FOR BAND C BETAWD = CONTINUUM COEFFICIENTS FOR BAND C APWD,BPWD = CAPPHI COEFFICIENTS FOR BAND C ATPWD,BTPWD = CAPPSI COEFFICIENTS FOR BAND C BDLOWD = LOWEST FREQUENCY IN EACH FREQ BAND C BDHIWD = HIGHEST FREQUENCY IN EACH FREQ BAND C AB15WD = THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINW = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C SKO2D = 1./BETINW, USED IN SPA88 FOR CONT. COEFFS C SKC1R = BETAWD/BETINW, USED FOR CONT. COEFF. FOR C 15 UM BAND IN FST88 C SKO3R = RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO C BETINW, USED FOR 9.6 UM CONT COEFF IN FST88 C DATA FOR AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). COMMON / BDWIDE / AWIDE,BWIDE,BETAWD, 1 APWD,BPWD,ATPWD,BTPWD, 2 BDLOWD,BDHIWD,BETINW, 3 AB15WD,SKO2D,SKC1R,SKO3R C C COMMON BLOCK BDCOMB CONTAINS RANDOM BAND PARAMETERS FOR THE LW C CALCULATIONS USING COMBINED WIDE FREQUENCY BANDS BETWEEN 160 AND C 1200 CM-1,AS WELL AS THE 2270-2380 BAND FOR SOURCE CALC. C BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1 C BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS) C FOR 560-1200 CM-1 C BAND 15: FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE C CALCULATION ONLY C THUS NBLY PRESENTLY EQUALS 15 C C BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER C ACOMB = RANDOM "A" PARAMETER FOR (NBLY) BANDS C BCOMB = RANDOM "B" PARAMETER FOR (NBLY) BANDS C BETACM = CONTINUUM COEFFICIENTS FOR (NBLY) BANDS C APCM,BPCM = CAPPHI COEFFICIENTS FOR (NBLY) BANDS C ATPCM,BTPCM = CAPPSI COEFFICIENTS FOR (NBLY) BANDS C BDLOCM = LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C BDHICM = HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS C AO3CM = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE C BANDS C BO3CM = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE C BANDS C AB15CM = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS C REPRESENTING THE 15 UM BAND COMPLEX OF CO2 C BETINC = CONT.COEFFICIENT FOR A SPECIFIED WIDE C FREQ.BAND (800-990 AND 1070-1200 CM-1). C IBAND = INDEX NO OF THE 40 WIDE BANDS USED IN C COMBINED WIDE BAND CALCULATIONS. IN OTHER C WORDS,INDEX TELLING WHICH OF THE 40 WIDE C BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN C EACH OF THE FIRST 8 COMBINED WIDE BANDS C DATA FOR ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM ARE C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS C ARE FROM ROBERTS (1976). IBAND INDEX VALUES ARE OBTAINED BY C EXPERIMENTATION. COMMON / BDCOMB / IBAND(40),ACOMB(NBLY),BCOMB(NBLY), 1 BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY), 2 BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC, 3 AO3CM(3),BO3CM(3),AB15CM(2) C C COMMON BLOCK TABCOM CONTAINS QUANTITIES PRECOMPUTED IN SUBROUTINE C TABLE FOR USE IN THE LONGWAVE RADIATION PROGRAM: C EM1 = E1 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C EM1WDE = E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1 C INTERVAL C TABLE1 = E2 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C TABLE2 = TEMPERATURE DERIVATIVE OF TABLE1 C TABLE3 = MASS DERIVATIVE OF TABLE1 C EM3 = E3 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C SOURCE = PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR C BANDS USED IN CTS CALCULATIONS C DSRCE = TEMPERATURE DERIVATIVE OF SOURCE C IND = INDEX, WITH VALUE IND(I)=I. USED IN FST88 C INDX2 = INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXV = INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXVM = KMAXV(L),USED FOR DO LOOP INDICES C COMMON / TABCOM / IND(IMAX),INDX2(LP1V),KMAXV(LP1), 1 KMAXVM,IDUMMY2(IMAX+LP1V+LP1+1) COMMON/TABCOM/EM1(28,180),EM1WDE(28,180),TABLE1(28,180), 1 TABLE2(28,180),TABLE3(28,180),EM3(28,180),SOURCE(28,NBLY), 2 DSRCE(28,NBLY) C DIMENSION SUM(28,180),PERTSM(28,180),SUM3(28,180), 1 SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW),DBDTNB(28,NBLW) DIMENSION ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), 1 TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), 2 SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), 3 R1(28),R2(28),S2(28),T3(28),R1WD(28) DIMENSION EXPO(180),FAC(180) DIMENSION CNUSB(30),DNUSB(30) DIMENSION ALFANB(NBLW),AROTNB(NBLW) DIMENSION ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), 1 BETANB(NBLW) COMMON/TBLTMP/ DELCM(NBLY) C**************************************** C***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15 C....FOR NARROW-BANDS... DO 101 N=1,NBLW ANB(N)=ARNDM(N) BNB(N)=BRNDM(N) CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N)) DELNB(N)=BANDHI(N)-BANDLO(N) BETANB(N)=BETAD(N) 101 CONTINUE AB15(1)=ANB(57)*BNB(57) AB15(2)=ANB(58)*BNB(58) C....FOR WIDE BANDS... AB15WD=AWIDE*BWIDE C C***COMPUTE INDICES: IND,INDX2,KMAXV DO 111 I=1,IMAX IND(I)=I 111 CONTINUE ICNT=0 DO 113 I1=1,L I2E=LP1-I1 DO 115 I2=1,I2E ICNT=ICNT+1 INDX2(ICNT)=LP1*(I2-1)+LP2*I1 115 CONTINUE 113 CONTINUE KMAXV(1)=1 DO 117 I=2,L KMAXV(I)=KMAXV(I-1)+(LP2-I) 117 CONTINUE KMAXVM=KMAXV(L) C***COMPUTE RATIOS OF CONT. COEFFS SKC1R=BETAWD/BETINW SKO3R=BETAD(61)/BETINW SKO2D=ONE/BETINW C C****BEGIN TABLE COMPUTATIONS HERE*** C***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES C---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS C WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM C 100K TO 370K. C---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF C 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS C ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS. ZMASS(1)=H1M16 DO 201 J=1,180 JP=J+1 ZROOT(J)=SQRT(ZMASS(J)) ZMASS(JP)=ZMASS(J)*H1P25892 201 CONTINUE DO 203 I=1,28 XTEMV(I)=HNINETY+TEN*I TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I) FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I) 203 CONTINUE C******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY C FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE C MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD) C THEN COMBINED (USING IBAND) INTO SOURCE. DO 205 N=1,NBLY DO 205 I=1,28 SOURCE(I,N)=ZERO 205 CONTINUE DO 207 N=1,NBLX DO 207 I=1,28 SRCWD(I,N)=ZERO 207 CONTINUE C---BEGIN FREQ. LOOP (ON N) DO 211 N=1,NBLX IF (N.LE.46) THEN C***THE 160-1200 BAND CASES CENT=CENTNB(N+16) DEL=DELNB(N+16) BDLO=BANDLO(N+16) BDHI=BANDHI(N+16) ENDIF IF (N.EQ.NBLX) THEN C***THE 2270-2380 BAND CASE CENT=CENTNB(NBLW) DEL=DELNB(NBLW) BDLO=BANDLO(NBLW) BDHI=BANDHI(NBLW) ENDIF C***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE C ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS. NSUBDS=(DEL-H1M3)/10+1 DO 213 NSB=1,NSUBDS IF (NSB.NE.NSUBDS) THEN CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE DNUSB(NSB)=TEN ELSE CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI) DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO) ENDIF C1=(H37412M5)*CNUSB(NSB)**3 C---BEGIN TEMP. LOOP (ON I) DO 215 I=1,28 X(I)=H1P4387*CNUSB(NSB)/XTEMV(I) X1(I)=EXP(X(I)) SRCS(I)=C1/(X1(I)-ONE) SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB) 215 CONTINUE 213 CONTINUE 211 CONTINUE C***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE C AND DSRCE DO 221 N=1,40 DO 221 I=1,28 SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N) 221 CONTINUE DO 223 N=9,NBLY DO 223 I=1,28 SOURCE(I,N)=SRCWD(I,N+32) 223 CONTINUE DO 225 N=1,NBLY DO 225 I=1,27 DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1 225 CONTINUE DO 231 N=1,NBLW ALFANB(N)=BNB(N)*ANB(N) AROTNB(N)=SQRT(ALFANB(N)) 231 CONTINUE C***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR C USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE C BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ. C RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT. C DO 301 N=1,NBLW CENT=CENTNB(N) DEL=DELNB(N) C---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT C IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR C THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY. DO 303 IA=1,3 ANU=CENT+HAF*(IA-2)*DEL C1=(H37412M5)*ANU*ANU*ANU+H1M20 C---TEMPERATURE LOOP--- DO 305 I=1,28 X(I)=H1P4387*ANU/XTEMV(I) X1(I)=EXP(X(I)) SC(I)=C1/((X1(I)-ONE)+H1M20) DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1) 305 CONTINUE IF (IA.EQ.2) THEN DO 307 I=1,28 SRC1NB(I,N)=DEL*SC(I) DBDTNB(I,N)=DEL*DSC(I) 307 CONTINUE ENDIF 303 CONTINUE 301 CONTINUE C***NEXT COMPUTE R1,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION C WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A C DIFFERENT DEPENDENCE ON (ZMASS). C---ALSO OBTAIN R1WD, WHICH IS R1 SUMMED OVER THE 160-560 CM-1 RANGE DO 311 I=1,28 SUM4(I)=ZERO SUM6(I)=ZERO SUM7(I)=ZERO SUM8(I)=ZERO SUM4WD(I)=ZERO 311 CONTINUE DO 313 N=1,NBLW CENT=CENTNB(N) C***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4 C SUM6,SUM7,SUM8 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN DO 315 I=1,28 SUM4(I)=SUM4(I)+SRC1NB(I,N) SUM6(I)=SUM6(I)+DBDTNB(I,N) SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N) SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N) 315 CONTINUE ENDIF C***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD IF (CENT.GT.160. .AND. CENT.LT.560.) THEN DO 316 I=1,28 SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N) 316 CONTINUE ENDIF 313 CONTINUE DO 317 I=1,28 R1(I)=SUM4(I)/TFOUR(I) R2(I)=SUM6(I)/FORTCU(I) S2(I)=SUM7(I)/FORTCU(I) T3(I)=SUM8(I)/FORTCU(I) R1WD(I)=SUM4WD(I)/TFOUR(I) 317 CONTINUE DO 401 J=1,180 DO 401 I=1,28 SUM(I,J)=ZERO PERTSM(I,J)=ZERO SUM3(I,J)=ZERO SUMWDE(I,J)=ZERO 401 CONTINUE C---FREQUENCY LOOP BEGINS--- DO 411 N=1,NBLW CENT=CENTNB(N) C***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN DO 413 J=1,180 X2(J)=AROTNB(N)*ZROOT(J) EXPO(J)=EXP(-X2(J)) 413 CONTINUE DO 415 J=1,180 IF (X2(J).GE.HUNDRED) THEN EXPO(J)=ZERO ENDIF 415 CONTINUE DO 417 J=121,180 FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J)) 417 CONTINUE DO 419 J=1,180 DO 419 I=1,28 SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J) PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J) 419 CONTINUE DO 421 J=121,180 DO 421 I=1,28 SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J) 421 CONTINUE ENDIF C---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE) IF (CENT.GT.160. .AND. CENT.LT.560.) THEN DO 420 J=1,180 DO 420 I=1,28 SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J) 420 CONTINUE ENDIF 411 CONTINUE DO 431 J=1,180 DO 431 I=1,28 EM1(I,J)=SUM(I,J)/TFOUR(I) TABLE1(I,J)=PERTSM(I,J)/FORTCU(I) 431 CONTINUE DO 433 J=121,180 DO 433 I=1,28 EM3(I,J)=SUM3(I,J)/FORTCU(I) 433 CONTINUE DO 441 J=1,179 DO 441 I=1,28 TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN 441 CONTINUE DO 443 J=1,180 DO 443 I=1,27 TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1 443 CONTINUE DO 445 I=1,28 TABLE2(I,180)=ZERO 445 CONTINUE DO 447 J=1,180 TABLE3(28,J)=ZERO 447 CONTINUE DO 449 J=1,2 DO 449 I=1,28 EM1(I,J)=R1(I) 449 CONTINUE DO 451 J=1,120 DO 451 I=1,28 EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT 451 CONTINUE DO 453 J=121,180 DO 453 I=1,28 EM3(I,J)=EM3(I,J)/ZMASS(J) 453 CONTINUE C***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY. C WE USE R1WD AND SUMWDE OBTAINED ABOVE. DO 501 J=1,180 DO 501 I=1,28 EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I) 501 CONTINUE DO 503 J=1,2 DO 503 I=1,28 EM1WDE(I,J)=R1WD(I) 503 CONTINUE RETURN END SUBROUTINE O3INT(O3O3,SIGL) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: O3INT COMPUTE ZONAL MEAN OZONE FOR SIGMA LYRS C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: THIS CODE WRITTEN AT GFDL... C CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE, C FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4 C CODE IS CALLED ONLY ONCE. C C PROGRAM HISTORY LOG: C 84-01-01 FELS AND SCHWARZKOPF,GFDL. C 89-07-07 K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE. C C USAGE: CALL O3INT(O3,SIGL) C INPUT ARGUMENT LIST: C SIGL - LAYER SIGMA (K=1 IS LOWEST MODEL LAYER) C OUTPUT ARGUMENT LIST: C O3 - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4) C DIMENSIONED(L,N,IS),WHERE L(=37) IS LATITUDE BETWEEN C N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR) C ,AND IS(=4) DEFINES THE SEASON-WIN,SPR,SUM,FALL. C C OUTPUT FILES: C OUTPUT - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ C.... PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3 C.. CODE ADAPTED FOR MRF USE, IN-LINE..... K.A.C. JUNE 1989 C.... LAUNCHER======SUBROUTINE O3INT(T41,O3O3) C.. OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C ********************************************************* C SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 **** C ..... K.CAMPANA OCTOBER 1988 CCCC DIMENSION T41(LP2,2),O3O3(37,L,4) DIMENSION SIGL(L),O3O3(37,L,4) C ********************************************************* DIMENSION QI(82) DIMENSION DDUO3N(19,L),RO31(10,41),RO32(10,41),DUO3N(19,41) DIMENSION TEMPN(19) DIMENSION O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), 1 O3LO4(10,16) DIMENSION O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33) DIMENSION O35DEG(37,L) DIMENSION RSTD(81),RO3(10,41),RO3M(10,40),RBAR(L),RDATA(81), 1 PHALF(LP1),PSTD(LP2),P(81),PH(82) EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46)) EQUIVALENCE (P1(1),P(1)),(P2(1),P(49)) DATA PH1/ 0., 1 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, 1 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, 1 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, 1 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, 1 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, 1 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, 1 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, 1 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, 1 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, 1 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, 1 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/ DATA PH2/ 1 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, 1 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, 1 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, 1 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, 1 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, 1 0.1099026E 00, 0.1286765E 00, 0.1506574E 00, 0.1763932E 00, 1 0.2065253E 00, 0.2415209E 00, 0.2814823E 00, 0.3266369E 00, 1 0.3774861E 00, 0.4345638E 00, 0.4984375E 00, 0.5697097E 00, 1 0.6490189E 00, 0.7370409E 00, 0.8344896E 00, 0.9421190E 00, 1 0.1000000E 01/ DATA P1/ 1 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, 1 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, 1 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, 1 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, 1 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, 1 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, 1 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, 1 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, 1 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, 1 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, 1 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, 1 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/ DATA P2/ 1 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, 1 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, 1 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, 1 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, 1 0.1015345E 00, 0.1189603E 00, 0.1391863E 00, 0.1630739E 00, 1 0.1908004E 00, 0.2235461E 00, 0.2609410E 00, 0.3036404E 00, 1 0.3513750E 00, 0.4055375E 00, 0.4656677E 00, 0.5335132E 00, 1 0.6083618E 00, 0.6923932E 00, 0.7845676E 00, 0.8875882E 00, 1 0.1000000E 01/ DATA O3HI1/ * .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, * .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, * .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, * .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, * .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, * .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, * .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, * .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, * 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, * 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, * 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, * 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, * 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, * 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, * 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, * 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/ DATA O3HI2/ * 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, * 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, * 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, * 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, * 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, * 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, * 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, * 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, * 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/ DATA O3LO1/ * 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, * 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, * 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, * 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, * 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, * 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, * 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, * .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, * .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, * .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, * .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, * .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, * .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, * .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, * .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, * .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/ DATA O3LO2/ * 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, * 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, * 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, * 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, * 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, * 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, * .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, * .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, * .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, * .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, * .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, * .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, * .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, * .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, * .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, * .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/ DATA O3LO3/ * 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, * 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, * 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, * 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, * 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, * 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, * .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, * .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, * .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, * .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, * .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, * .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, * .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, * .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, * .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, * .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/ DATA O3LO4/ * 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, * 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, * 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, * 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, * 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, * 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, * 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, * .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, * .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, * .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, * .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, * .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, * .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, * .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, * .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, * .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/ C***READ IN USER-SPECIFIED PRESSURES,IN MB. THIS CAN BE OUTPUT FROM PTZ CKAC .. FILE 41 FROM PTZ(PSFC=1013.25 MB) 606 FORMAT (5E16.9) CCC READ (8,606) (PSTD(K),K=1,LP2) CCC READ (8,606) (PHALF(K),K=1,LP1) CO222 *************************************************** PSS=1013.250 E 0 PSTD(1) = 0. E 0 PSTD(LP2) = PSS DO 202 K=2,LP1 PSTD(K) = SIGL(LP2-K) * PSS 202 CONTINUE PHALF(1) = 0. E 0 PHALF(LP1) = PSS DO 204 K=1,LM1 PHALF(K+1) = 0.5 E 0 * (PSTD(K+1)+PSTD(K+2)) 204 CONTINUE CKAC DO 300 K=1,LP2 CKAC PSTD(K) = T41(K,1) CK300 CONTINUE CKAC DO 301 K=1,LP1 CKAC PHALF(K) = T41(K,2) CK301 CONTINUE CC REWIND 66 CO222 *************************************************** NKK=41 NK=81 NKP=NK+1 DO 24 K=1,LP1 PHALF(K)=PHALF(K)*1.0E 03 24 PSTD(K)=PSTD(K+1)*1.0E 03 DO 25 K=1,NK PH(K)=PH(K)*1013250. 25 P(K)=P(K)*1013250. PH(NKP)=PH(NKP)*1013250. CKAC WRITE (6,3) PH CKAC WRITE (6,3) P WRITE (6,3) (PHALF(K),K=1,LP1) WRITE (6,3) (PSTD(K),K=1,LP1) C***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM. DO 1010 K=1,25 DO 1010 N=1,10 RO31(N,K)=O3HI(N,K) RO32(N,K)=O3HI(N,K) 1010 CONTINUE C DO 3000 NCASE=1,4 ITAPE=NCASE+50 IPLACE=2 IF (NCASE.EQ.2) IPLACE=4 IF (NCASE.EQ.3) IPLACE=1 IF (NCASE.EQ.4) IPLACE=3 C***NCASE=1: SPRING (IN N.H.) C***NCASE=2: FALL (IN N.H.) C***NCASE=3: WINTER (IN N.H.) C***NCASE=4: SUMMER (IN N.H.) IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN DO 1011 K=26,41 DO 1011 N=1,10 RO31(N,K)=O3LO1(N,K-25) RO32(N,K)=O3LO2(N,K-25) 1011 CONTINUE ENDIF IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN DO 1031 K=26,41 DO 1031 N=1,10 RO31(N,K)=O3LO3(N,K-25) RO32(N,K)=O3LO4(N,K-25) 1031 CONTINUE ENDIF DO 30 KK=1,NKK DO 31 N=1,10 DUO3N(N,KK)=RO31(11-N,KK) 31 DUO3N(N+9,KK)=RO32(N,KK) DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK)) 30 CONTINUE C***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN DO 1024 KK=1,NKK DO 1025 N=1,19 TEMPN(N)=DUO3N(20-N,KK) 1025 CONTINUE DO 1026 N=1,19 DUO3N(N,KK)=TEMPN(N) 1026 CONTINUE 1024 CONTINUE ENDIF C***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE C LEVELS CKAC WRITE (6,800) DUO3N C***BEGIN LATITUDE (10 DEG) LOOP DO 33 N=1,19 DO 22 KK=1,NKK 22 RSTD(KK)=DUO3N(N,KK) NKM=NK-1 NKMM=NK-3 C BESSELS HALF-POINT INTERPOLATION FORMULA DO 60 K=4,NKMM,2 KI=K/2 60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ 1RSTD(KI-1))/16. RDATA(2)=.5*(RSTD(2)+RSTD(1)) RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1)) C PUT UNCHANGED DATA INTO NEW ARRAY DO 61 K=1,NK,2 KQ=(K+1)/2 61 RDATA(K)=RSTD(KQ) C---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT C WRITE (6,798) RDATA C CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL DO 99 KK=1,L RBAR(KK)=0. C LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN DO 98 K=1,NK IF(PH(K+1).LT.PHALF(KK)) GO TO 98 IF(PH(K).GT.PHALF(KK+1)) GO TO 98 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK 1)+RDATA(K)*(PH(K+1)-PHALF(KK)) IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(K 1K)+RDATA(K)*(PH(K+1)-PH(K)) IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(K 1K)+RDATA(K)*(PHALF(KK+1)-PH(K)) 98 CONTINUE RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK)) IF(RBAR(KK).GT..0000) GO TO 99 C CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE C OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND C PHALF(KK). PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM C RDATA DO 29 K=1,NK IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K 1) 29 CONTINUE 99 CONTINUE C CALCULATE TOTAL OZONE O3RD=0. DO 89 KK=1,80 89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK)) O3RD=O3RD+RDATA(81)*(P(81)-PH(81)) O3RD=O3RD/980. O3TOT=0. DO 88 KK=1,L 88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK)) O3TOT=O3TOT/980. C UNITS ARE MICROGRAMS/CM**2 O3DU=O3TOT/2.144 C O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM) C--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT C WRITE (6,796) O3RD,O3TOT,O3DU DO 23 KK=1,L 23 DDUO3N(N,KK)=RBAR(KK)*.01 33 CONTINUE C***END OF LATITUDE LOOP C C***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF C 10 DEG VALUES DO 1060 KK=1,L DO 1061 N=1,19 O35DEG(2*N-1,KK)=DDUO3N(N,KK) 1061 CONTINUE DO 1062 N=1,18 O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK)) 1062 CONTINUE 1060 CONTINUE C***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE CO222 *************************************************** CC WRITE (66) O35DEG DO 302 JJ=1,37 DO 302 KEN=1,L O3O3(JJ,KEN,IPLACE) = O35DEG(JJ,KEN) 302 CONTINUE CO222 *************************************************** CCC WRITE (ITAPE,101) O35DEG CKAC WRITE (6,101) O35DEG 3000 CONTINUE C***END OF LOOP OVER CASES RETURN 1 FORMAT(10F4.2) 2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X) 3 FORMAT(10E12.5) C 796 FORMAT(3E12.5) 797 FORMAT(10F7.2) C 798 FORMAT(20F6.2) 799 FORMAT(19F6.4) 800 FORMAT(19F6.2) 101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, *1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,) END SUBROUTINE O3INTN(O3O3,PSTD) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: O3INT COMPUTE ZONAL MEAN OZONE FOR SIGMA LYRS C PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 C C ABSTRACT: THIS CODE WRITTEN AT GFDL... C CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE, C FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4 C CODE IS CALLED ONLY ONCE. C C PROGRAM HISTORY LOG: C 84-01-01 FELS AND SCHWARZKOPF,GFDL. C 89-07-07 K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE. C C USAGE: CALL O3INT(O3,SIGL) C INPUT ARGUMENT LIST: C SIGL - LAYER SIGMA (K=1 IS LOWEST MODEL LAYER) C OUTPUT ARGUMENT LIST: C O3 - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4) C DIMENSIONED(L,N,IS),WHERE L(=37) IS LATITUDE BETWEEN C N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR) C ,AND IS(=4) DEFINES THE SEASON-WIN,SPR,SUM,FALL. C C OUTPUT FILES: C OUTPUT - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ C.... PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3 C.. CODE ADAPTED FOR MRF USE, IN-LINE..... K.A.C. JUNE 1989 C.... LAUNCHER======SUBROUTINE O3INT(T41,O3O3) C.. NO INPUT, JUST CALCULATE COMPLETE 81 LAYER DATA FOR LATER C.. INTERPOLATION K.A.C. DEC 1994.. C.. OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) PARAMETER (NL=81, NLP1=NL+1) C ********************************************************* C SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 **** C ..... K.CAMPANA OCTOBER 1988 CCCC DIMENSION T41(LP2,2),O3O3(37,L,4) CO3 DIMENSION SIGL(L),O3O3(37,L,4) DIMENSION O3O3(37,NL,4) C ********************************************************* DIMENSION QI(82) DIMENSION DDUO3N(19,NL),RO31(10,41),RO32(10,41),DUO3N(19,41) DIMENSION TEMPN(19) DIMENSION O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), 1 O3LO4(10,16) DIMENSION O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33) DIMENSION O35DEG(37,NL) DIMENSION RSTD(81),RO3(10,41),RO3M(10,40),RBAR(NL),RDATA(81), 1 PHALF(NL),PSTD(NL),P(81),PH(82) EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46)) EQUIVALENCE (P1(1),P(1)),(P2(1),P(49)) DATA PH1/ 0., 1 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, 1 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, 1 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, 1 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, 1 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, 1 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, 1 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, 1 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, 1 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, 1 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, 1 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/ DATA PH2/ 1 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, 1 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, 1 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, 1 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, 1 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, 1 0.1099026E 00, 0.1286765E 00, 0.1506574E 00, 0.1763932E 00, 1 0.2065253E 00, 0.2415209E 00, 0.2814823E 00, 0.3266369E 00, 1 0.3774861E 00, 0.4345638E 00, 0.4984375E 00, 0.5697097E 00, 1 0.6490189E 00, 0.7370409E 00, 0.8344896E 00, 0.9421190E 00, 1 0.1000000E 01/ DATA P1/ 1 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, 1 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, 1 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, 1 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, 1 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, 1 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, 1 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, 1 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, 1 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, 1 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, 1 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, 1 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/ DATA P2/ 1 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, 1 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, 1 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, 1 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, 1 0.1015345E 00, 0.1189603E 00, 0.1391863E 00, 0.1630739E 00, 1 0.1908004E 00, 0.2235461E 00, 0.2609410E 00, 0.3036404E 00, 1 0.3513750E 00, 0.4055375E 00, 0.4656677E 00, 0.5335132E 00, 1 0.6083618E 00, 0.6923932E 00, 0.7845676E 00, 0.8875882E 00, 1 0.1000000E 01/ DATA O3HI1/ * .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, * .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, * .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, * .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, * .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, * .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, * .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, * .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, * 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, * 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, * 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, * 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, * 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, * 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, * 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, * 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/ DATA O3HI2/ * 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, * 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, * 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, * 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, * 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, * 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, * 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, * 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, * 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/ DATA O3LO1/ * 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, * 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, * 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, * 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, * 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, * 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, * 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, * .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, * .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, * .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, * .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, * .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, * .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, * .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, * .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, * .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/ DATA O3LO2/ * 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, * 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, * 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, * 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, * 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, * 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, * .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, * .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, * .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, * .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, * .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, * .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, * .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, * .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, * .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, * .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/ DATA O3LO3/ * 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, * 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, * 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, * 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, * 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, * 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, * .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, * .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, * .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, * .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, * .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, * .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, * .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, * .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, * .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, * .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/ DATA O3LO4/ * 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, * 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, * 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, * 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, * 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, * 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, * 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, * .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, * .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, * .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, * .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, * .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, * .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, * .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, * .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, * .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/ NKK=41 NK=81 NKP=NK+1 DO 25 K=1,NK PH(K)=PH(K)*1013250. 25 P(K)=P(K)*1013250. PH(NKP)=PH(NKP)*1013250. DO 24 K=1,NL PSTD(K)=P(K) 24 CONTINUE CKAC WRITE (6,3) PH CKAC WRITE (6,3) P CKAC WRITE (6,3) (PSTD(K),K=1,LP1) C***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM. DO 1010 K=1,25 DO 1010 N=1,10 RO31(N,K)=O3HI(N,K) RO32(N,K)=O3HI(N,K) 1010 CONTINUE C DO 3000 NCASE=1,4 ITAPE=NCASE+50 IPLACE=2 IF (NCASE.EQ.2) IPLACE=4 IF (NCASE.EQ.3) IPLACE=1 IF (NCASE.EQ.4) IPLACE=3 C***NCASE=1: SPRING (IN N.H.) C***NCASE=2: FALL (IN N.H.) C***NCASE=3: WINTER (IN N.H.) C***NCASE=4: SUMMER (IN N.H.) IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN DO 1011 K=26,41 DO 1011 N=1,10 RO31(N,K)=O3LO1(N,K-25) RO32(N,K)=O3LO2(N,K-25) 1011 CONTINUE ENDIF IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN DO 1031 K=26,41 DO 1031 N=1,10 RO31(N,K)=O3LO3(N,K-25) RO32(N,K)=O3LO4(N,K-25) 1031 CONTINUE ENDIF DO 30 KK=1,NKK DO 31 N=1,10 DUO3N(N,KK)=RO31(11-N,KK) 31 DUO3N(N+9,KK)=RO32(N,KK) DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK)) 30 CONTINUE C***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN DO 1024 KK=1,NKK DO 1025 N=1,19 TEMPN(N)=DUO3N(20-N,KK) 1025 CONTINUE DO 1026 N=1,19 DUO3N(N,KK)=TEMPN(N) 1026 CONTINUE 1024 CONTINUE ENDIF C***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE C LEVELS CKAC WRITE (6,800) DUO3N C***BEGIN LATITUDE (10 DEG) LOOP DO 33 N=1,19 DO 22 KK=1,NKK 22 RSTD(KK)=DUO3N(N,KK) NKM=NK-1 NKMM=NK-3 C BESSELS HALF-POINT INTERPOLATION FORMULA DO 60 K=4,NKMM,2 KI=K/2 60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ 1RSTD(KI-1))/16. RDATA(2)=.5*(RSTD(2)+RSTD(1)) RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1)) C PUT UNCHANGED DATA INTO NEW ARRAY DO 61 K=1,NK,2 KQ=(K+1)/2 61 RDATA(K)=RSTD(KQ) C---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT C WRITE (6,798) RDATA CO3 DO 23 KK=1,L DO 23 KK=1,NL 23 DDUO3N(N,KK)=RDATA(KK)*.01 33 CONTINUE C***END OF LATITUDE LOOP C C***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF C 10 DEG VALUES CO3 DO 1060 KK=1,L DO 1060 KK=1,NL DO 1061 N=1,19 O35DEG(2*N-1,KK)=DDUO3N(N,KK) 1061 CONTINUE DO 1062 N=1,18 O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK)) 1062 CONTINUE 1060 CONTINUE C***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE CO222 *************************************************** CC WRITE (66) O35DEG DO 302 JJ=1,37 CO3 DO 302 KEN=1,L DO 302 KEN=1,NL O3O3(JJ,KEN,IPLACE) = O35DEG(JJ,KEN) 302 CONTINUE CO222 *************************************************** CCC WRITE (ITAPE,101) O35DEG CKAC WRITE (6,101) O35DEG 3000 CONTINUE C***END OF LOOP OVER CASES RETURN 1 FORMAT(10F4.2) 2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X) 3 FORMAT(10E12.5) C 796 FORMAT(3E12.5) 797 FORMAT(10F7.2) C 798 FORMAT(20F6.2) 799 FORMAT(19F6.4) 800 FORMAT(19F6.2) 101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, *1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,) END SUBROUTINE OZON2D(SIGL,QO3,SFCP,XLAT,RSIN1,RCOS1,RCOS2) CFPP$ NOCONCUR R C ... COMPUTE MODEL LYR O3 PROFILE FROM THE ORIGINAL GFDL DATA PARAMETER (L= 28 ) PARAMETER (NL=81,NLP1=NL+1,LNGTH=37*NL) DIMENSION SIGL( 28 ),PSM( 384 ) DIMENSION QO3( 384 , 28 ),SFCP( 384 ),XLAT( 384 ) DIMENSION JJROW( 384 ), TTHAN( 384 ) DIMENSION QO3O3( 384 ,NL) C... ************************************************************** C-- SEASONAL CLIMATOLOGIES OF O3 FROM O3INTN COMMON /SEASO3/ C- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... 1 DDUO3N(37,NL), DDO3N2(37,NL), DDO3N3(37,NL), DDO3N4(37,NL) 2 , PRGFDL(NL) C... ************************************************************** C... BEGIN HERE ..... RNDG = 180./ 3.141593E+0 DO 10 I=1, 384 TH2=0.2 E 0*XLAT(I)*RNDG JJROW(I)=19.001 E 0-TH2 TTHAN(I)=(19-JJROW(I))-TH2 10 CONTINUE C.... SEASONAL AND SPATIAL INTERPOLATION DONE BELOW. DO 20 K=1,NL DO 20 I=1, 384 DO3V = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) 1 +RCOS1*DDO3N3(JJROW(I),K) 2 +RCOS2*DDO3N4(JJROW(I),K) DO3VP = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) 1 +RCOS1*DDO3N3(JJROW(I)+1,K) 2 +RCOS2*DDO3N4(JJROW(I)+1,K) C... NOW LATITUDINAL INTERPOLATION, AND C CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4) C FLIP VERTICAL COORDINATE TOO... QO3O3(I,NL+1-K) = 1. E -4 * (DO3V+TTHAN(I)*(DO3VP-DO3V)) 20 CONTINUE C... VERTICAL (LINEAR IN LN P) INTERPOLATE FOR EACH GRIDPOINT NUMITR = 0 ILOG = NL 21 CONTINUE ILOG = (ILOG+1)/2 IF(ILOG.EQ.1) GO TO 22 NUMITR = NUMITR + 1 GO TO 21 22 CONTINUE DO 60 K=1,L NHALF=(NL+1)/2 DO 30 I=1, 384 JJROW(I) = NHALF PSM(I) = SFCP(I) * SIGL(K) 30 CONTINUE DO 40 IT=1,NUMITR NHALF=(NHALF+1)/2 DO 40 I=1, 384 IF(PSM(I).LT.PRGFDL(JJROW(I))) THEN JJROW(I) = JJROW(I) + NHALF ELSE IF(PSM(I).GE.PRGFDL(JJROW(I)-1)) THEN JJROW(I) = JJROW(I) - NHALF ENDIF JJROW(I) = MIN(JJROW(I),NL) JJROW(I) = MAX(JJROW(I),2) 40 CONTINUE DO 50 I=1, 384 IF(PSM(I).GT.PRGFDL(1)) THEN QO3(I,K) = QO3O3(I,1) ELSE IF(PSM(I).LT.PRGFDL(NL)) THEN QO3(I,K) = QO3O3(I,NL) ELSE APLO = ALOG(PRGFDL(JJROW(I)-1)) APUP = ALOG(PRGFDL(JJROW(I))) QO3(I,K) = QO3O3(I,JJROW(I)) + (ALOG(PSM(I))-APUP) / 1 (APLO-APUP) * 2 (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I))) ENDIF 50 CONTINUE 60 CONTINUE RETURN END SUBROUTINE OZ2D(SIGL,QO3,SFCP,XLAT) CFPP$ NOCONCUR R C ... COMPUTE MODEL LYR O3 PROFILE FROM THE ORIGINAL NASA DATA PARAMETER (L= 28 ) PARAMETER (LOZ=17,J5=37) DIMENSION SIGL( 28 ),PSM( 384 ) DIMENSION QO3( 384 , 28 ),SFCP( 384 ),XLAT( 384 ) DIMENSION WGTS( 384 ),JLATS( 384 ) DIMENSION JJROW( 384 ) DIMENSION QO3O3( 384 ,LOZ) C... ************************************************************** C-- MONTHLY CLIMATOLOGY OF O3 FROM O3SBUV common /sbuv/ psnasa(loz),o3nasa(j5,loz) C... ************************************************************** C... BEGIN HERE ..... RNDG = 180./ 3.141593E+0 DO 10 I=1, 384 RLAT=XLAT(I)*RNDG do 5 j=1,j5 lato3=90-(j-1)*5 xlato3=lato3 if (xlato3.lt.rlat) then jlats(i)=j wgts(i) = (rlat-xlato3)/5. CC go to 1013 go to 10 end if 5 continue CC 1013 if (i.eq.1.or.i.eq. 384 ) then CC print 716,i,rlat,xlato3,jlats(i),wgts(i) CC end if 10 CONTINUE 716 format(1h ,'i=',i3,'rlat,xlato3,jlats,wgts=',2e12.3,i5,e12.3) CC print 717,(o3nasa(1,k),k=1,loz) 717 format(1h ,'o3nasa=',6e13.4) C.... LATITUDINAL (linear) INTERPOLATION DONE BELOW. C FLIP VERTICAL COORDINATE TOO... DO 20 K=1,LOZ DO 20 I=1, 384 QO3O3(I,LOZ+1-K)=wgts(i) 1 * (o3nasa(jlats(i)-1,k)-o3nasa(jlats(i),k)) 2 + o3nasa(jlats(i),k) 20 CONTINUE C... VERTICAL (LINEAR IN LN P) INTERPOLATE FOR EACH GRIDPOINT NUMITR = 0 CC ILOG = NL ILOG = LOZ 21 CONTINUE ILOG = (ILOG+1)/2 IF(ILOG.EQ.1) GO TO 22 NUMITR = NUMITR + 1 GO TO 21 22 CONTINUE DO 60 K=1,L CC NHALF=(NL+1)/2 NHALF=(LOZ+1)/2 DO 30 I=1, 384 JJROW(I) = NHALF PSM(I) = SFCP(I) * SIGL(K) 30 CONTINUE DO 40 IT=1,NUMITR NHALF=(NHALF+1)/2 DO 40 I=1, 384 IF(PSM(I).LT.psnasa(JJROW(I))) THEN JJROW(I) = JJROW(I) + NHALF ELSE IF(PSM(I).GE.psnasa(JJROW(I)-1)) THEN JJROW(I) = JJROW(I) - NHALF ENDIF CC JJROW(I) = MIN(JJROW(I),NL) JJROW(I) = MIN(JJROW(I),LOZ) JJROW(I) = MAX(JJROW(I),2) 40 CONTINUE DO 50 I=1, 384 IF(PSM(I).GT.psnasa(1)) THEN QO3(I,K) = QO3O3(I,1) ELSE IF(PSM(I).LT.psnasa(LOZ)) THEN QO3(I,K) = QO3O3(I,LOZ) ELSE APLO = ALOG(psnasa(JJROW(I)-1)) APUP = ALOG(psnasa(JJROW(I))) QO3(I,K) = QO3O3(I,JJROW(I)) + (ALOG(PSM(I))-APUP) / 1 (APLO-APUP) * 2 (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I))) ENDIF 50 CONTINUE 60 CONTINUE RETURN END subroutine o3sbuv(fhour,idate,ko3,o3out,pstr,jerr) c ******************************************************** c * COMPUTES O3 CLIMO FROM 12 MONTH DATASET, LINEARLY * c * INTERPOLATED TO DAY,MON OF THE FCST. THEN CREATE * c * A 5 DEG ARRAY FROM THE 10 DEG CLIMATOLOGY...FOR * c * EASE WHEN DOING A LATITUDINAL INTERPOLATION * c * THANKS TO S MOORTHI for NEW O3 CLIMO...KAC DEC 1996* c * INPUT: * c * idate=NMC date-time * c * fhour=forecast hour * c * ko3=unit number of O3 climatology * c * OUTPUT : * c * o3out=5-deg O3 climo for forecast date(np->spole) * c * pstr=pressure (mb) for the climo lyrs (k=1 is top) * c * jerr=0 if o3 file exists, =1 if not (gfdl=default) * c ******************************************************** c GEOS ozone data parameter (jmr=18, BLTE=-85.0, DLTE=10.0) parameter (loz=17,jmout=37) C INTEGER imon(12),DAYS(12),idate(4) dimension ilat(jmr,12) dimension O3R(JMR,LOZ,12),O3TMP(jmr,loz) dimension o3out(jmout,loz),pstr(loz) DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/ C... BEGIN HERE ...... ida=idate(3) imo=idate(2) c... FIND current day and month, initial values in ida,imo! c will not worry about leap year, since it will take a c 120-year (WHAT?) forecast to be off by 1 month. If this c is deemed a problem, need to redo this calculation. c if (fhour.ge.24.) then c... number of days into the forecast numdyz=fhour/24.0 + 0.01 c... get day-of-year, remember climate runs are for years imo1=imo-1 jday = ida if (imo1.gt.0) then jday=0 do 7 ken=1,imo1 jday=jday+days(ken) 7 continue jday=jday+ida end if nmdtot = jday+numdyz ndayr = mod(nmdtot,365) if (ndayr.eq.0) ndayr=365 c... now get month from day-of-year mday=0 do 8 ken=1,11 mday=mday+days(ken) imo=ken if (ndayr.le.mday) then ida=ndayr-(mday-days(imo)) go to 9 end if 8 continue imo=12 9 continue print 66,fhour,numdyz,jday,nmdtot,ndayr 66 format(' SBUVO3 climo hr=',f10.1, 1 ' numdyz,jday,nmdtot,ndayr=',4i8) end if coef=1.655e-6 C JERR = 0 REWIND KO3 do 10 l=1,loz READ (KO3,15,ERR=998,END=999) pstr(l) 15 format(f10.3) 10 continue CCC print 16,pstr 16 format(1h ,' O3 pressures=',8f10.3) do 40 nm=1,12 do 30 j=1,jmr READ (KO3,19,ERR=998,END=999) imon(nm),ilat(j,nm), 1 (o3r(j,l,nm), l=1,10) READ (KO3,20,ERR=998,END=999) (o3r(j,l,nm), l=11,loz) 30 continue do 35 j=1,jmr do 35 l=1,loz o3r(j,l,nm) = o3r(j,l,nm) * coef 35 continue 40 continue c... do a linear interpolation in time, where we assume that c the ozone data is valid for mid-month c monL is the preceeding month, monC for current mo, and c monR is the future month.. monL=imo-1 monC=imo monR=imo+1 if (monL.lt.1) monL=12 if (monR.gt.12) monR=1 c... difL=number of days beteen mid-months of the current and c preceeding mo, difR=same for current and future mo.. c... delL=number of days between current day and mon, c delR=same for current day and next month. c sign convention as if we were using day of year calculations. midL=days(monL)/2 midC=days(monC)/2 midR=days(monR)/2 difL=-(days(monL)-midL+midC) difR= (days(monC)-midC+midR) delday=ida-midC if (ida.gt.midC) then do 60 j=1,jmr do 60 l=1,loz O3TMP(j,l)=o3r(j,l,monC)+(o3r(j,l,monR)-o3r(j,l,monC)) 1 * delday/difR 60 continue else if (ida.lt.midC) then do 65 j=1,jmr do 65 l=1,loz O3TMP(j,l)=o3r(j,l,monC)+(o3r(j,l,monL)-o3r(j,l,monC)) 1 * delday/difL 65 continue else if (ida.eq.midC) then do 70 j=1,jmr do 70 l=1,loz O3TMP(j,l)=o3r(j,l,monC) 70 continue end if print 200,imo,ida c... linearly interpolate to 5 deg zonal means jmr1=jmr-1 do 80 j=1,jmr1 j1=j*2 j2=j1+1 do 80 l=1,loz o3out(j1,l)=O3TMP(j,l) o3out(j2,l)=0.5*(O3TMP(j,l)+O3TMP(j+1,l)) 80 continue do 85 l=1,loz o3out(1,l)=O3TMP(1,l) o3out(jmout-1,l)=O3TMP(jmr,l) o3out(jmout,l)=O3TMP(jmr,l) 85 continue 19 format(i2,i4,10f6.2) 20 format(6x,10f6.2) 200 format(1h1,' ozone climatology for month,day=',2i4) return 998 PRINT 988,ko3 jerr = 1 RETURN 999 PRINT 989,ko3 jerr = 1 RETURN 988 FORMAT(1H ,'....ERROR READING NASA OZONE, UNIT=',I4) 989 FORMAT(1H ,'....E.O.F READING NASA OZONE, UNIT=',I4) END SUBROUTINE RMSGT(Q,X,Y,W,DEL,R) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RMSGT COMPUTES ROOT MEAN SQUARE. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-25 C C ABSTRACT: COMPUTES THE ROOT MEAN SQUARE IN EACH LEVEL AND OF C THE VERTICAL INTEGRAL (WHEN APPROPRIATE) GIVEN THE SPECTRAL C COEFFICIENTS OF THE MODEL VARIABLES OR THE TENDENCIES. C THE RESULTS ARE PRINTED. RMSGT IS STRICTLY DIAGNOSTIC. C C PROGRAM HISTORY LOG: C 88-04-25 JOSEPH SELA C C USAGE: CALL RMSGT (Q, X, Y, W, DEL, R) C INPUT ARGUMENT LIST: C Q - SPECTRAL COEFS OF LN(PSFC) OR ITS TENDENCY. C X - SPECTRAL COEFS OF DIVERGENCE OR ITS TENDENCY. C Y - SPECTRAL COEFS OF TEMPERATURE OR ITS TENDENCY. C W - SPECTRAL COEFS OF VORTICITY OR ITS TENDENCY. C DEL - SIGMA SPACING AT EACH LAYER. C R - SPECTRAL COEFS OF MIXING RATIO OR ITS TENDENCY. C C OUTPUT FILES: C OUTPUT - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ DIMENSION Q( 4033 ),X( 4033 , 28 ),Y( 4033 , 28 ) DIMENSION W( 4033 , 28 ),R( 4033 , 28 ) DIMENSION 1RX( 28 ),RY( 28 ),RW( 28 ),DEL( 28 ),RR( 28 ) VR=0. E 0 VX=0. E 0 VY=0. E 0 VW=0. E 0 DO 10 K=1, 28 CALL BARTRI(X(1,K),X(1,K),RX(K)) CALL BARTRI(Y(1,K),Y(1,K),RY(K)) CALL BARTRI(W(1,K),W(1,K),RW(K)) VX=VX+RX(K)*DEL(K) VY=VY+RY(K)*DEL(K) VW=VW+RW(K)*DEL(K) 10 CONTINUE DO 20 K=1, 28 CALL BARTRI(R(1,K),R(1,K),RR(K)) VR=VR+RR(K)*DEL(K) 20 CONTINUE CALL BARTRI(Q,Q,RQ) C PRINT 50 C50 FORMAT(1H ,'BEGIN RMSGT') PRINT 100,VX,VW,VY,VR,RQ 100 FORMAT(1H0,'DIV VORT TEMP MIXRATIO LN(PS) ',5(E13.7,1X)) 200 FORMAT(1H ,4(2X,E13.7)) DO 40 K=1, 28 IF(K.GT. 28 )GO TO 35 PRINT 200,RX(K),RW(K),RY(K),RR(K) GO TO 39 35 CONTINUE PRINT 200,RX(K),RW(K),RY(K) 39 CONTINUE 40 CONTINUE C PRINT 300 C300 FORMAT(1H ,'END RMSGT') RETURN END SUBROUTINE BARTRI (F, G, FGBAR) DIMENSION F( 4033 ),G( 4033 ) C JOFF(N,L)=( 63 )*( 64 )-( 63 -L)*( 64 -L)+2*(N-L) C L=0 FGBAR = 0. DO 1 N=0, 62 FGBAR = FGBAR + F(JOFF(N,L)+1)*G(JOFF(N,L)+1) 1 CONTINUE DO 11 N=0, 62 FGBAR = FGBAR + F(JOFF(N,L)+2)*G(JOFF(N,L)+2) 11 CONTINUE FGBAR=FGBAR*0.5 DO 3 L=1, 62 DO 2 N=L, 62 FGBAR = FGBAR + F(JOFF(N,L)+1)*G(JOFF(N,L)+1) 2 CONTINUE DO 22 N=L, 62 FGBAR = FGBAR + F(JOFF(N,L)+2)*G(JOFF(N,L)+2) 22 CONTINUE 3 CONTINUE FGBAR = SQRT(FGBAR) RETURN END CFPP$ NOCONCUR R CFPP$ EXPAND(FPVS) C----------------------------------------------------------------------- SUBROUTINE SASCNV(IMX2,IMX22,KMX,JCAP,DELT,DEL,SL,SLK,PS, & Q1,T1,CLDWRK,RN,KBOT,KTOP,KUO,SPD,LAT,SLIMSK,DOT, & HPBL,GAMT,GAMQ,QCI,QRS,DELX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SASCNV COMPUTES CONVECTIVE HEATING AND MOISNG C PRGMMR: HUA-LU PAN ORG: W/NMC23 DATE: 92-03-01 C C ABSTRACT: COMPUTES CONVECTIVE HEATING AND MOISTENING USING A ONE C CLOUD TYPE ARAKAWA-SCHUBERT CONVECTION SCHEME ORIGINALLY DEVELOPED C BY GEORG GRELL. THE SCHEME INCLUDES UPDRAFT AND DOWNDRAFT EFFECTS. C THE CLOSURE IS THE CLOUD WORK FUNCTION. BOTH UPDRAFT AND DOWNDRAFT C ARE ASSUMED TO BE SATURATED AND THE HEATING AND MOISTENING ARE C ACCOMPLISHED BY THE COMPENSATING ENVIRONMENT. THE NAME COMES FROM C "SIMPLIFIED ARAKAWA-SCHUBERT CONVECTION PARAMETERIZATION". C C PROGRAM HISTORY LOG: C 92-03-01 HUA-LU PAN C C USAGE: CALL SASCNV(IM,IX,KM,JCAP,DELT,DEL,SL,SLK,PS,QN,TN, C & Q1,T1,RN,KBOT,KTOP,KUO,SPD,LAT,SLIMSK) C C INPUT ARGUMENT LIST: C IM - INTEGER NUMBER OF POINTS C IX - LEADING DIMENSION OF QN,TN,Q1,T1,SPD C KM - INTEGER NUMBER OF LEVELS C JCAP - INTEGER SPECTRAL TRUNCATION C DT - REAL TIME STEP IN SECONDS C DEL - REAL (KM) SIGMA LAYER THICKNESS C SL - REAL (KM) SIGMA VALUES C SLK - REAL (KM) SIGMA VALUES TO THE KAPPA C PS - REAL (IM) SURFACE PRESSURE IN KILOPASCALS (CB) C QN - REAL (IX,KM) PREVIOUS SPECIFIC HUMIDITY IN KG/KG C TN - REAL (IX,KM) PREVIOUS TEMPERATURE IN KELVIN C Q1 - REAL (IX,KM) CURRENT SPECIFIC HUMIDITY IN KG/KG C T1 - REAL (IX,KM) CURRENT TEMPERATURE IN KELVIN C SPD - REAL (IX,KM) CURRENT WIND SPEED C LAT - INTEGER CURRENT LATITUDE INDEX C SLIMSK - REAL (IM) LAND(1),SEA(0), ICE(2) FLAG C C OUTPUT ARGUMENT LIST: C Q1 - REAL (IX,KM) ADJUSTED SPECIFIC HUMIDITY IN KG/KG C T1 - REAL (IX,KM) ADJUSTED TEMPERATURE IN KELVIN C RN - REAL (IM) CONVECTIVE RAIN IN METERS C KBOT - INTEGER (IM) CLOUD BOTTOM LEVEL C KTOP - INTEGER (IM) CLOUD TOP LEVEL C KUO - INTEGER (IM) BIT FLAG INDICATING DEEP CONVECTION C C SUBPROGRAMS CALLED: C FPVS - FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE C C REMARKS: FUNCTION FPVS IS INLINED BY FPP. C NONSTANDARD AUTOMATIC ARRAYS ARE USED. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ DIMENSION DEL(KMX),SL(KMX),SLK(KMX),PS(IMX2), C & Q1(IMX22,KMX*NCLD),T1(IMX22,KMX),RN(IMX2), & Q1(IMX22,KMX),T1(IMX22,KMX),RN(IMX2), & KBOT(IMX2),KTOP(IMX2),KUO(IMX2) DIMENSION SPD(IMX2,KMX),SLIMSK(IMX2),DOT(IMX2,KMX),CLDWRK(IMX2) DIMENSION HPBL(IMX2),GAMT(IMX2),GAMQ(IMX2) DIMENSION QCI(IMX2,KMX),QRS(IMX2,KMX) C PHYSICAL PARAMETERS PARAMETER(G= 9.8000E+0 ,RD= 2.8705E+2 ,RV= 4.6150E+2 , & CP= 1.0046E+3 ,HVAP= 2.5000E+6 ,T0C= 2.7315E+2 ,QMIN=1.E 1-30) PARAMETER(CPOEL=CP/HVAP,ELOCP=HVAP/CP, & EL2ORC=HVAP*HVAP/(RV*CP),EPS=RD/RV,EPSM1=RD/RV-1., & FV=1./EPS-1.) PARAMETER(TERR=0.,C0=.002 ) PARAMETER(FACT1=( 1.8460E+3 - 4.1855E+3 )/RV,FACT2=HVAP/RV-FACT1*T 10C) C C THIS IS CVS TEST AND TEST C C LOCAL VARIABLES AND ARRAYS DIMENSION P( 384 , 28 ),PDOT( 384 ),ACRTFCT( 384 ), & TO( 384 , 28 ),QO( 384 , 28 ) DIMENSION QESO( 384 , 28 ) DIMENSION TVO( 384 , 28 ),DBYO( 384 , 28 ), & ZO( 384 , 28 ), & HEO( 384 , 28 ),HESO( 384 , 28 ), & QRCD( 384 , 28 ),DELLAH( 384 , 28 ),DELLAQ( 384 , 28 ), & HCKO( 384 , 28 ), & QCKO( 384 , 28 ),ETA( 384 , 28 ), & ETAD( 384 , 28 ), & QRCDO( 384 , 28 ), & PWO( 384 , 28 ),PWDO( 384 , 28 ),DTCONV( 384 ), & DELTV( 384 ),ACRT( 384 ) DIMENSION PSFC( 384 ),HMAX( 384 ),KB( 384 ), DELQ( 384 ), & HKBO( 384 ),QKBO( 384 ),KBCON( 384 ),PBCDIF( 384 ), & VMAX( 384 ),KDS( 384 ), & HMIN( 384 ),LMIN( 384 ),JMIN( 384 ),PWAVO( 384 ), & AA1( 384 ),VSHEAR( 384 ),SHRMAX( 384 ), & KSHMAX( 384 ),EDT( 384 ), & EDTO( 384 ),PWEVO( 384 ), & QCOND( 384 ), & HCDO( 384 ),QCDO( 384 ),DDP( 384 ),PP2( 384 ), & ADET( 384 ),AATMP( 384 ), & XHKB( 384 ),XQKB( 384 ),XPWAV( 384 ),XPWEV( 384 ),XHCD( 384 ), & XAA0( 384 ),F( 384 ),XK( 384 ),XMB( 384 ),KTCON( 384 ), & EDTX( 384 ),XQCD( 384 ), & HSBAR( 384 ),XMBMAX( 384 ),XLAMB( 384 ),XLAMD( 384 ), & KBDTR( 384 ), & EXCESS( 384 ),KPBL( 384 ),PLCL( 384 ),KLCL( 384 ),KTDOWN( 384 ) DIMENSION DELHBAR( 384 ),DELQBAR( 384 ),DELTBAR( 384 ) DIMENSION PCRIT(15), ACRITT(15), ACRIT(15) C REAL MBDT SAVE PCRIT, ACRITT LOGICAL TOTFLG, CNVFLG( 384 ), DWNFLG( 384 ), 1 DWNFLG2( 384 ), FLG( 384 ), & LFCFLG,GCMFLG,lclflg,evaflg DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., & 350.,300.,250.,200.,150./ DATA ACRITT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ CCC PARAMETER(XK1=.2,XLHOR=10000.,XHVER=5000., PARAMETER(XK1=2.E-5,XLHOR=3.E4,XHVER=5000.,theimax=1., CCC & XC1=5.E-7,XC2=3.E4,XC3=10.,ECESSCR=3.0) & XC1=1.E-7,XC2=1.E4,XC3=3.E3,ECESSCR=3.0,EDTK1=3.E4) C GDAS DERIVED ACRIT C DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688, C & .743,.813,.886,.947,1.138,1.377,1.896/ C----------------------------------------------------------------------- C INITIALIZE ARRAYS C IM=IMX2 KM=KMX C pi = 4.*atan(1.) C C-RSM IF(1.EQ.1) THEN C-RSM gcmflg = .false. C-RSM BETAl = .3 C-RSM ELSE gcmflg = .true. BETAl = .05 C-RSM ENDIF C lfcflg = .true. !!! old trigger lclflg = .true. !!! LCL cloud bottom in the new trigger evaflg = .true. !!! Evaporational efficiency C C NCLOUD = NCLD NCLOUD = 1 KCI = 0 KRS = 0 IF(NCLOUD.GT.1) THEN KCI = KM KRS = 2*KM ENDIF DO I=1,IM RN(I)=0. KBOT(I)=KM+1 KTOP(I)=0 KUO(I)=0 CNVFLG(I) = .TRUE. DTCONV(I) = 3600. CLDWRK(I) = 0. PDOT(I) = 0. XMBMAX(I) = .3 EXCESS(I) = 0.0 PLCL(I) = 0.0 KPBL(I) = 1 ENDDO DO K = 1, 15 ACRIT(K) = ACRITT(K) * (975. - PCRIT(K)) ENDDO DT2 = 2. * DELT dtmin = max(dt2,1200.) dtmax = max(dt2,3600.) C MODEL TUNABLE PARAMETERS ARE ALL HERE MBDT = 10. if(gcmflg) then EDTMAXl = MIN(EDTK1/DELX,.9) EDTMAXs = .9 if(evaflg) EDTMAXs = .3 else EDTMAXl = .3 EDTMAXs = .3 endif ALPHAl = .5 ALPHAs = .5 betas = .05 EVEF = 0.07 if(evaflg) then evfact = 1. - EDTMAXs endif PDPDWN=0. PDETRN=200. W1l = -2.E-3 * (JCAP / 62.) W2l = -1.E-2 * (JCAP / 62.) ccc W3l = -1.E-2 * (JCAP / 62.) ccc W4l = -1.E-3 * (JCAP / 62.) W3l = -2.E-3 * (JCAP / 62.) W4l = -2.E-4 * (JCAP / 62.) W1s = -2.E-3 * (JCAP / 62.) W2s = -1.E-2 * (JCAP / 62.) W3s = -2.E-3 * (JCAP / 62.) W4s = -2.E-4 * (JCAP / 62.) CCCCC IF(IM.EQ.384) THEN CCCCC LATD = 45 CCCCC LOND = 376 CCCCC ELSEIF(IM.EQ.768) THEN CCCCC LATD = 80 CCCCC LOND = 81 CCCCC ELSE CCCCC LATD = 0 CCCCC LOND = 0 CCCCC ENDIF C C DEFINE TOP LAYER FOR SEARCH OF THE DOWNDRAFT ORIGINATING LAYER C AND THE MAXIMUM THETAE FOR UPDRAFT C KBMAX = KM KBM = KM KMAX = KM DO K = 1, KM IF(SL(K).GT..45) KBMAX = K + 1 IF(SL(K).GT..7) KBM = K + 1 IF(SL(K).GT..05) KMAX = K + 1 ENDDO C C CONVERT SURFACE PRESSURE TO MB FROM CB C DO I = 1, IM PSFC(I) = PS(I) * 10. ENDDO DO K = 1, KM DO I = 1, IM QCI(I,K) = 0.0 QRS(I,K) = 0.0 PWO(I,K) = 0. PWDO(I,K) = 0. ENDDO ENDDO DO K = 1, KMAX DO I = 1, IM P(I,K) = PSFC(I) * SL(K) PWO(I,K) = 0. PWDO(I,K) = 0. TO(I,K) = T1(I,K) QO(I,K) = Q1(I,K) DBYO(I,K) = 0. ENDDO ENDDO C C COLUMN VARIABLES C P IS PRESSURE OF THE LAYER (MB) C T IS TEMPERATURE AT T-DT (K)..TN C Q IS MIXING RATIO AT T-DT (KG/KG)..QN C TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN C QO IS MIXING RATIO AT T+DT (KG/KG)..Q1 C DO K = 1, KMAX DO I = 1, IM QESO(I,K) = 10. * FPVS(T1(I,K)) QESO(I,K) = EPS * QESO(I,K) / (P(I,K) + EPSM1 * QESO(I,K)) QESO(I,K) = MAX(QESO(I,K),QMIN) C QO(I,K) = MIN(QO(I,K),QESO(I,K)) TVO(I,K) = TO(I,K) + FV * TO(I,K) * MAX(QO(I,K),QMIN) CCC IF(NCLOUD.GT.1) THEN CCC QSUM = 0. CCC DO ICLOUD = 1,NCLOUD CCC KK = K + KM * (ICLOUD-1) CCC QSUM = MAX(Q1(I,KK),QMIN) + QSUM CCC ENDDO CCC tvfac = (1.+ MAX(Q1(I,K),QMIN)) / (1.+ QSUM) CCC TVO(I,K) = TVO(I,K)*tvfac CCC ENDIF ENDDO ENDDO CCC print*,'SASCNV j ncloud ',lat,ncloud C C HYDROSTATIC HEIGHT ASSUME ZERO TERR C DLNSIG = LOG(SL(1)) DO I = 1, IM ZO(I,1) = TERR - DLNSIG * RD / G * TVO(I,1) ENDDO DO K = 2, KMAX DLNSIG = LOG(SL(K) / SL(K-1)) DO I = 1, IM ZO(I,K) = ZO(I,K-1) - DLNSIG * RD / G & * .5 * (TVO(I,K) + TVO(I,K-1)) ENDDO ENDDO ccc print*,'step j',lat C COMPUTE MOIST STATIC ENERGY DO K = 1, KMAX DO I = 1, IM HEO(I,K) = G * ZO(I,K) + CP * TO(I,K) + HVAP * QO(I,K) HESO(I,K) = G * ZO(I,K) + CP * TO(I,K) + HVAP * QESO(I,K) C HEO(I,K) = MIN(HEO(I,K),HESO(I,K)) ENDDO ENDDO C C DETERMINE LEVEL WITH LARGEST MOIST STATIC ENERGY C THIS IS THE LEVEL WHERE UPDRAFT STARTS C DO I = 1, IM HMAX(I) = HEO(I,1) KB(I) = 1 ENDDO DO K = 2, KBM DO I = 1, IM IF(HEO(I,K).GT.HMAX(I).AND.CNVFLG(I)) THEN KB(I) = K HMAX(I) = HEO(I,K) ENDIF ENDDO ENDDO DO I = 1, IM IF(QO(I,KB(I)).LT.QMIN) CNVFLG(I) = .FALSE. ENDDO C C SEARCH FOR DOWNDRAFT ORIGINATING LEVEL ABOVE THETA-E MINIMUM C ccc print*,'step j',lat DO I = 1, IM HMIN(I) = HESO(I,1) LMIN(I) = KBMAX JMIN(I) = KBMAX ENDDO ccc print*,'step j kbmax ',lat,kbmax DO K = 2, KBMAX DO I = 1, IM IF(HESO(I,K).LT.HMIN(I).AND.CNVFLG(I)) THEN LMIN(I) = K + 1 HMIN(I) = HESO(I,K) ENDIF ENDDO ENDDO ccc print*,'step j',lat C DO K = 1, KMAX - 1 C DO I = 1, IM C TOL(I,K) = .5 * (TO(I,K) + TO(I,K+1)) C QOL(I,K) = .5 * (QO(I,K) + QO(I,K+1)) C QESOL(I,K) = .5 * (QESO(I,K) + QESO(I,K+1)) C HEOL(I,K) = .5 * (HEO(I,K) + HEO(I,K+1)) C HESOL(I,K) = .5 * (HESO(I,K) + HESO(I,K+1)) C ENDDO C ENDDO DO K = 1, KMAX - 1 DO I = 1, IM IF(CNVFLG(I)) THEN CCC if(lat.eq.26) print*,' j i k t tv q p ', CCC 2 lat,i,k,to(i,k),tvo(i,k),q1(i,k), CCC 1 q1(i,k+km),q1(i,k+2*km),zo(i,k),p(i,k) DZ = .5 * (ZO(I,K+1) - ZO(I,K)) DP = .5 * (P(I,K+1) - P(I,K)) ES = 10. * FPVS(TO(I,K+1)) PPRIME = P(I,K+1) + EPSM1 * ES QS = EPS * ES / PPRIME DQSDP = - QS / PPRIME DESDT = ES * (FACT1 / TO(I,K+1) + FACT2 / (TO(I,K+1)**2)) DQSDT = QS * P(I,K+1) * DESDT / (ES * PPRIME) GAMMA = EL2ORC * QESO(I,K+1) / (TO(I,K+1)**2) DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) DQ = DQSDT * DT + DQSDP * DP TO(I,K) = TO(I,K+1) + DT QO(I,K) = QO(I,K+1) + DQ PO = .5 * (P(I,K) + P(I,K+1)) QESO(I,K) = 10. * FPVS(TO(I,K)) QESO(I,K) = EPS * QESO(I,K) / (PO + EPSM1 * QESO(I,K)) QESO(I,K) = MAX(QESO(I,K),QMIN) C QO(I,K) = MIN(QO(I,K),QESO(I,K)) HEO(I,K) = .5 * G * (ZO(I,K) + ZO(I,K+1)) + & CP * TO(I,K) + HVAP * QO(I,K) HESO(I,K) = .5 * G * (ZO(I,K) + ZO(I,K+1)) + & CP * TO(I,K) + HVAP * QESO(I,K) ENDIF ENDDO ENDDO c k = kmax c do i = 1, im c heol(i,k) = heo(i,k) c hesol(i,k) = heso(i,k) c enddo CCCCC IF(LAT.EQ.LATD.AND.CNVFLG(LOND)) THEN CCCCC PRINT *, ' HEO =' CCCCC PRINT 6001, (HEO(LOND,K),K=1,KMAX) CCCCC PRINT *, ' HESO =' CCCCC PRINT 6001, (HESO(LOND,K),K=1,KMAX) CCCCC PRINT *, ' TO =' CCCCC PRINT *, ' QO =' CCCCC PRINT 6003, (QO(LOND,K),K=1,KMAX) CCCCC PRINT *, ' QSO =' CCCCC PRINT 6003, (QESO(LOND,K),K=1,KMAX) CCCCC ENDIF ccc print*,'step j',lat C C LOOK FOR CONVECTIVE CLOUD BASE AS THE LEVEL OF FREE CONVECTION C DO I = 1, IM IF(CNVFLG(I)) THEN INDX = KB(I) HKBO(I) = HEO(I,INDX) QKBO(I) = QO(I,INDX) ENDIF ENDDO DO I = 1, IM FLG(I) = CNVFLG(I) KBCON(I) = KMAX ENDDO C if(lfcflg) then DO K = 1, KBMAX DO I = 1, IM IF(FLG(I).AND.K.GT.KB(I)) THEN HSBAR(I) = HESO(I,K) IF(HKBO(I).GT.HSBAR(I)) THEN FLG(I) = .FALSE. KBCON(I) = K ENDIF ENDIF ENDDO ENDDO DO I = 1, IM IF(CNVFLG(I)) THEN PBCDIF(I) = -P(I,KBCON(I)) + P(I,KB(I)) c PDOT(I) = 10.* DOT(I,KBCON(I)) IF(PBCDIF(I).GT.150.) CNVFLG(I) = .FALSE. IF(KBCON(I).EQ.KMAX) CNVFLG(I) = .FALSE. ENDIF ENDDO else C C DETERMINE MESOSCALE TRIGGER C ccc print*,'step j',lat DO K = 1,KMAX DO I = 1,IM IF(FLG(I).AND.ZO(I,K).GE.HPBL(I)) THEN KPBL(I) = K FLG(I) = .FALSE. ENDIF ENDDO ENDDO ccc print*,'step j',lat DO I = 1,IM IF(CNVFLG(I)) THEN INDX = KB(I) INDP = KPBL(I) CCC THEI = XK1*DELX/XLHOR*(1.-ZO(I,INDX)/XHVER) thei = theimax/pi*(atan(xk1*(delx-xlhor))+pi/2.) CCC THEC = GAMT(I) THEC = GAMT(I) + EPS * TVO(I,1) * GAMQ(I) IF(ZO(I,INDX).LE.HPBL(I)) THEN THEB = THEC ELSE DELZA = MAX(ZO(I,INDX) - HPBL(I),QMIN) THEKB = TVO(I,INDX)/SLK(INDX) THEKH = TVO(I,INDP)/SLK(INDP) THEAVG = (THEKB+THEKH)/2. THEDIF = (THEKB-THEKH)/DELZA DZFAC = MIN(XC1*DELZA**2.+XC2/THEAVG*THEDIF,50.) DZFAC = MAX(DZFAC,0.) THEB = THEC*EXP(-DZFAC) ENDIF OMGKB = DOT(I,INDX)*10. OMGKBP1 = DOT(I,INDX+1)*10. OMGDIF = (OMGKB-OMGKBP1)/(P(I,INDX)-P(I,INDX+1)) OMGFAC = (MIN(ABS(OMGDIF),1.e50))**(1./3.) IF(OMGDIF.LT.0.) THEN OMGFAC = -1.*OMGFAC ENDIF THEOM = MAX((THEI+THEB)*(1.+delx/XC3*OMGFAC),0.) EXCESS(I) = MIN(THEOM,ECESSCR) CCC if(lat.eq.26) print*,'I lat INDX kpbl hpbl gamt ',i,lat,indx, CCC 1 kpbl(i),hpbl(i),gamt(i),gamq(i) CCC if(lat.eq.26)print*,'i lat the1 theb omg omgfac thermal ', CCC 1 i,lat,thei,theb,omgkb,omgfac,theom CHSY IF(THERMAL.LT.HESO(I,KBCON(I))) CNVFLG(I) = .FALSE. ENDIF ENDDO C ccc print*,'step j',lat DO I = 1,IM IF(CNVFLG(I)) THEN INDX = KB(I) RH = MIN(MAX(QO(I,INDX)/QESO(I,INDX),QMIN),1.) THERMAL = TO(I,INDX)+EXCESS(I) CHI = THERMAL/(1669.0-122.0*RH-THERMAL) PLCL(I) = P(I,INDX)*(RH**CHI) IF(PLCL(I).LT.P(I,KBMAX).OR.PLCL(I).GT.P(I,INDX)) THEN CNVFLG(I) = .FALSE. ENDIF ENDIF ENDDO ccc print*,'step j',lat DO I = 1, IM FLG(I) = CNVFLG(I) KLCL(I) = KMAX ENDDO DO K = 1,KBMAX DO I = 1,IM IF(FLG(I).AND.K.GT.KB(I).AND.P(I,K).LE.PLCL(I)) THEN KLCL(I) = K FLG(I) = .FALSE. ENDIF ENDDO ENDDO ccc print*,'step j',lat C DO I = 1,IM IF(CNVFLG(I)) THEN IF(KLCL(I).GE.KBMAX) CNVFLG(I) = .FALSE. IF((HKBO(I)+EXCESS(I)*CP).LT.HESO(I,KLCL(I))) 1 CNVFLG(I) = .FALSE. ENDIF ENDDO ccc print*,'step j',lat C C UPto here, KBCON is LCL. Put the CLoud bottom as LFC C C DO I = 1,IM IF((.not.lclflg).AND.CNVFLG(I)) THEN FLG(I) = .TRUE. ELSE KBCON(I) = KLCL(I) ENDIF ENDDO C DO K = 1, KBMAX DO I = 1, IM IF((.not.lclflg).AND.CNVFLG(I)) THEN IF(FLG(I).AND.K.GT.KB(I).AND.K.GE.KLCL(I)) THEN HSBAR(I) = HESO(I,K) IF((HKBO(I)+EXCESS(I)*CP).GT.HSBAR(I)) THEN FLG(I) = .FALSE. KBCON(I) = K ENDIF ENDIF ENDIF ENDDO ENDDO c endif C DO I = 1,IM IF(CNVFLG(I)) THEN IF(KBCON(I).GE.KBMAX) CNVFLG(I) = .FALSE. PDOT(I) = 10.* DOT(I,KBCON(I)) ENDIF ENDDO C TOTFLG = .TRUE. DO I = 1, IM TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) ENDDO IF(TOTFLG) RETURN C FOUND LFC, CAN DEFINE REST OF VARIABLES 6001 FORMAT(2X,-2P10F12.2) 6002 FORMAT(2X,10F12.2) 6003 FORMAT(2X,3P10F12.2) C C DETERMINE ENTRAINMENT RATE BETWEEN KB AND KBCON C ccc print*,'step j',lat DO I = 1, IM alpha = alphas if(slimsk(i).eq.1.) alpha = alphal IF(CNVFLG(I)) THEN CCC print*,'step j i kb kbcon zo ',lat,i,kb(i),kbcon(i),zo(i) IF(KB(I).EQ.1) THEN DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) - ZO(I,1) ELSE DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) & - .5 * (ZO(I,KB(I)) + ZO(I,KB(I)-1)) ENDIF IF(KBCON(I).NE.KB(I)) THEN XLAMB(I) = -LOG(ALPHA) / DZ ELSE XLAMB(I) = 0. ENDIF ENDIF ENDDO C DETERMINE UPDRAFT MASS FLUX DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I)) THEN ETA(I,K) = 1. ENDIF ENDDO ENDDO DO K = KBMAX, 2, -1 DO I = 1, IM IF(CNVFLG(I).AND.K.LT.KBCON(I).AND.K.GE.KB(I)) THEN DZ = .5 * (ZO(I,K+1) - ZO(I,K-1)) ETA(I,K) = ETA(I,K+1) * EXP(-XLAMB(I) * DZ) ENDIF ENDDO ENDDO DO I = 1, IM IF(CNVFLG(I).AND.KB(I).EQ.1.AND.KBCON(I).GT.1) THEN DZ = .5 * (ZO(I,2) - ZO(I,1)) ETA(I,1) = ETA(I,2) * EXP(-XLAMB(I) * DZ) ENDIF ENDDO ccc print*,'step j',lat C C WORK UP UPDRAFT CLOUD PROPERTIES C DO I = 1, IM IF(CNVFLG(I)) THEN INDX = KB(I) HCKO(I,INDX) = HKBO(I) QCKO(I,INDX) = QKBO(I) PWAVO(I) = 0. ENDIF ENDDO C C CLOUD PROPERTY BELOW CLOUD BASE IS MODIFIED BY THE ENTRAINMENT PROCES C DO K = 2, KMAX - 1 DO I = 1, IM IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN FACTOR = ETA(I,K-1) / ETA(I,K) ONEMF = 1. - FACTOR HCKO(I,K) = FACTOR * HCKO(I,K-1) + ONEMF * & .5 * (HEO(I,K) + HEO(I,K+1)) DBYO(I,K) = HCKO(I,K) - HESO(I,K) ENDIF IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN HCKO(I,K) = HCKO(I,K-1) DBYO(I,K) = HCKO(I,K) - HESO(I,K) ENDIF ENDDO ENDDO ccc print*,'step j',lat C DETERMINE CLOUD TOP DO I = 1, IM FLG(I) = CNVFLG(I) KTCON(I) = 1 ENDDO C DO K = 2, KMAX C KK = KMAX - K + 1 C DO I = 1, IM C IF(DBYO(I,KK).GE.0..AND.FLG(I).AND.KK.GT.KBCON(I)) THEN C KTCON(I) = KK + 1 C FLG(I) = .FALSE. C ENDIF C ENDDO C ENDDO C C CHECK INVERSION C DO K = 2, KMAX DO I = 1, IM CCC IF(DBYO(I,K).LT.0..AND.FLG(I).AND.K.GT. IF((DBYO(I,K)+EXCESS(I)*CP).LT.0..AND.FLG(I).AND.K.GT. 1 KBCON(I)) THEN KTCON(I) = K FLG(I) = .FALSE. ENDIF ENDDO ENDDO ccc print*,'step j',lat DO I = 1, IM FLG(I) = CNVFLG(I) KTDOWN(I) = 1 ENDDO DO K = KMAX,1,-1 DO I = 1, IM IF(DBYO(I,K).GE.0..AND.FLG(I).AND.K.GT. 1 KBCON(I).AND.K.LE.KTCON(I)) THEN KTDOWN(I) = K FLG(I) = .FALSE. ENDIF ENDDO ENDDO DO I = 1, IM IF(CNVFLG(I)) THEN KTCON(I) = KTDOWN(I) + 1 ENDIF ENDDO ccc print*,'step j',lat C C CHECK CLOUD DEPTH C DO I = 1, IM IF(CNVFLG(I).AND.(P(I,KBCON(I)) - P(I,KTCON(I))).LT.150.) & CNVFLG(I) = .FALSE. ENDDO TOTFLG = .TRUE. DO I = 1, IM TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) ENDDO IF(TOTFLG) RETURN C ccc print*,'step j',lat C DETRAINING CLOUD C DO I = 1, IM IF(CNVFLG(I)) THEN DZ = .5 * (ZO(I,KTCON(I))+ZO(I,KTCON(I)-1)) & - .5 * (ZO(I,KBCON(I))+ZO(I,KBCON(I)-1)) XLAMB(I) = -1. / DZ ENDIF DWNFLG(I) = CNVFLG(I) IF(CNVFLG(I).AND.(P(I,KBCON(I))-P(I,KTCON(I))).GT.PDETRN) & DWNFLG(I)=.FALSE. DWNFLG2(I) = CNVFLG(I) IF(CNVFLG(I).AND.(P(I,KBCON(I))-P(I,KTCON(I))).LT.PDPDWN) & DWNFLG2(I)=.FALSE. ENDDO DO K = 2, KMAX - 1 DO I = 1, IM IF(DWNFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN DZ = .5 * (ZO(I,K+1) - ZO(I,K-1)) ETA(I,K) = ETA(I,K-1) * EXP( XLAMB(I) * DZ) ENDIF ENDDO ENDDO C C CLOUD PROPERTY ABOVE CLOUD TOP IS MODIFIED BY THE DETRAINMENT PROCESS C ccc print*,'step j',lat DO K = 2, KMAX - 1 DO I = 1, IM IF(DWNFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN FACTOR = ETA(I,K-1) / ETA(I,K) ONEMF = 1. - FACTOR HCKO(I,K) = FACTOR * HCKO(I,K-1) + ONEMF * & .5 * (HEO(I,K) + HEO(I,K+1)) DBYO(I,K) = HCKO(I,K) - HESO(I,K) ENDIF ENDDO ENDDO C C Make sure that jmin is within the cloud C ccc print*,'step j',lat DO I = 1, IM IF(CNVFLG(I)) THEN JMIN(I) = MIN(LMIN(I),KTCON(I)-1) JMIN(I) = MAX(JMIN(I),KBCON(I)+1) ENDIF ENDDO ccc print*,'step j',lat DO I = 1, IM if(cnvflg(i).and.dwnflg2(i).and.jmin(i).le.kbcon(i)) & then cnvflg(i) = .false. dwnflg(i) = .false. dwnflg2(i) = .false. endif ENDDO CCCCC IF(LAT.EQ.LATD.AND.DWNFLG(LOND)) THEN CCCCC I = LOND CCCCC PRINT *, ' LMIN, PDOT=', LMIN(I), PDOT(I) CCCCC PRINT *, ' KBOT, KTOP, JMIN =', KBCON(I), KTCON(I), JMIN(I) CCCCC ENDIF TOTFLG = .TRUE. DO I = 1, IM TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) ENDDO IF(TOTFLG) RETURN C C COMPUTE CLOUD MOISTURE PROPERTY AND PRECIPITATION C ccc print*,'step j',lat DO I = 1, IM AA1(I) = 0. ENDDO DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN DZ = .5 * (ZO(I,K+1) - ZO(I,K-1)) DZ1 = (ZO(I,K) - ZO(I,K-1)) GAMMA = EL2ORC * QESO(I,K) / (TO(I,K)**2) QRCH = QESO(I,K) & + GAMMA * DBYO(I,K) / (HVAP * (1. + GAMMA)) FACTOR = ETA(I,K-1) / ETA(I,K) ONEMF = 1. - FACTOR QCKO(I,K) = FACTOR * QCKO(I,K-1) + ONEMF * & .5 * (QO(I,K) + QO(I,K+1)) DQ = ETA(I,K) * QCKO(I,K) - ETA(I,K) * QRCH C C BELOW LFC CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT C IF(DQ.GT.0.) THEN ETAH = .5 * (ETA(I,K) + ETA(I,K-1)) QLK = DQ / (ETA(I,K) + ETAH * C0 * DZ) AA1(I) = AA1(I) - DZ1 * G * QLK QC = QLK + QRCH PWO(I,K) = ETAH * C0 * DZ * QLK QCKO(I,K) = QC PWAVO(I) = PWAVO(I) + PWO(I,K) QCI(I,K) = QLK ENDIF ENDIF ENDDO ENDDO ccc print*,'step j',lat C C CALCULATE CLOUD WORK FUNCTION AT T+DT C DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LT.KTCON(I)) THEN DZ1 = ZO(I,K) - ZO(I,K-1) GAMMA = EL2ORC * QESO(I,K-1) / (TO(I,K-1)**2) RFACT = 1. + FV * CP * GAMMA & * TO(I,K-1) / HVAP AA1(I) = AA1(I) + & DZ1 * (G / (CP * TO(I,K-1))) & * DBYO(I,K-1) / (1. + GAMMA) & * RFACT AA1(I)=AA1(I)+ & DZ1 * G * FV * & MAX(0.,(QESO(I,K-1) - QO(I,K-1))) ENDIF ENDDO ENDDO ccc print*,'step j',lat DO I = 1, IM IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG(I) = .FALSE. IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG2(I) = .FALSE. IF(CNVFLG(I).AND.AA1(I).LE.0.) CNVFLG(I) = .FALSE. ENDDO CCCCC IF(LAT.EQ.LATD.AND.CNVFLG(LOND)) THEN CCCCC I = LOND CCCCC PRINT *, ' AA1 BEFORE DWNDRFT =', AA1(I) CCCCC ENDIF C C------- DOWNDRAFT CALCULATIONS C C DETERMINE LEVEL WITH LARGEST WIND SPEED DO I = 1, IM VMAX(I) = SPD(I,KB(I)) KDS(I) = KB(I) ENDDO DO K = 2, KMAX - 1 DO I = 1, IM IF(K.GE.KB(I).AND.SPD(I,K).GT.VMAX(I).AND.CNVFLG(I) & .AND.K.LE.KTCON(I)) THEN VMAX(I) = SPD(I,K) KDS(I) = K ENDIF ENDDO ENDDO ccc print*,'step j',lat C C--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR C DO I = 1, IM IF(CNVFLG(I)) THEN VSHEAR(I) = 0. SHRMAX(I) = 0. KSHMAX(I) = 1 ENDIF ENDDO DO K = 1, KMAX DO I = 1, IM cgcm IF(K.GE.KB(I).AND.K.LE.KDS(I).AND.CNVFLG(I)) THEN IF(K.GE.KB(I).AND.K.LE.KTCON(I).AND.CNVFLG(I)) THEN SHEAR = ABS((SPD(I,K+1)-SPD(I,K))/(ZO(I,K+1)-ZO(I,K))) VSHEAR(I) = VSHEAR(I) + SHEAR SHRMAX(I) = MAX(SHRMAX(I),SHEAR) IF(SHRMAX(I).EQ.SHEAR) KSHMAX(I) = K ENDIF ENDDO ENDDO DO I = 1, IM IF(CNVFLG(I)) THEN cgcm KNUMB = KDS(I) - KB(I) + 1 KNUMB = KTCON(I) - KB(I) + 1 KNUMB = MAX(KNUMB,1) VSHEAR(I) = 1.E3 * VSHEAR(I) / FLOAT(KNUMB) if(vshear(i).ge.1.35) then E1 = 1.591-.639*VSHEAR(I) & +.0953*(VSHEAR(I)**2)-.00496*(VSHEAR(I)**3) else e1 = 0.9 endif EDT(I)=1.-E1 EDT(I) = MIN(EDT(I),1.0) EDT(I) = MAX(EDT(I),.1) EDTO(I)=EDT(I) EDTX(I)=EDT(I) ENDIF ENDDO ccc print*,'step j',lat C DETERMINE DETRAINMENT RATE BETWEEN 1 AND KBDTR DO I = 1, IM KBDTR(I) = KBCON(I) beta = betas if(slimsk(i).eq.1.) beta = betal IF(CNVFLG(I)) THEN KBDTR(I) = KBCON(I) KBDTR(I) = MAX(KBDTR(I),1) XLAMD(I) = 0. IF(KBDTR(I).GT.1) THEN DZ = .5 * ZO(I,KBDTR(I)) + .5 * ZO(I,KBDTR(I)-1) & - ZO(I,1) XLAMD(I) = LOG(BETA) / DZ ENDIF ENDIF ENDDO ccc print*,'step j',lat C DETERMINE DOWNDRAFT MASS FLUX DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I)) THEN ETAD(I,K) = 1. ENDIF QRCDO(I,K) = 0. ENDDO ENDDO DO K = KBMAX, 2, -1 DO I = 1, IM IF(CNVFLG(I).AND.K.LT.KBDTR(I)) THEN DZ = .5 * (ZO(I,K+1) - ZO(I,K-1)) ETAD(I,K) = ETAD(I,K+1) * EXP(XLAMD(I) * DZ) ENDIF ENDDO ENDDO K = 1 DO I = 1, IM IF(CNVFLG(I).AND.KBDTR(I).GT.1) THEN DZ = .5 * (ZO(I,2) - ZO(I,1)) ETAD(I,K) = ETAD(I,K+1) * EXP(XLAMD(I) * DZ) ENDIF ENDDO ccc print*,'step j',lat C C--- DOWNDRAFT MOISTURE PROPERTIES C DO I = 1, IM PWEVO(I) = 0. FLG(I) = CNVFLG(I) ENDDO DO I = 1, IM IF(CNVFLG(I)) THEN JMN = JMIN(I) HCDO(I) = HEO(I,JMN) QCDO(I) = QO(I,JMN) QRCDO(I,JMN) = QESO(I,JMN) ENDIF ENDDO DO K = KMAX-1, 1, -1 DO I = 1, IM IF(CNVFLG(I).AND.K.LT.JMIN(I)) THEN DQ = QESO(I,K) DT = TO(I,K) GAMMA = EL2ORC * DQ / DT**2 DH = HCDO(I) - HESO(I,K) QRCDO(I,K)=DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH DETAD = ETAD(I,K+1) - ETAD(I,K) PWDO(I,K) = ETAD(I,K+1) * QCDO(I) - & ETAD(I,K) * QRCDO(I,K) PWDO(I,K) = PWDO(I,K) - DETAD * & .5 * (QRCDO(I,K) + QRCDO(I,K+1)) QCDO(I) = QRCDO(I,K) PWEVO(I) = PWEVO(I) + PWDO(I,K) ENDIF ENDDO ENDDO ccc print*,'step j',lat C IF(LAT.EQ.LATD.AND.DWNFLG(LOND)) THEN C I = LOND C PRINT *, ' PWAVO, PWEVO =', PWAVO(I), PWEVO(I) C ENDIF C C--- FINAL DOWNDRAFT STRENGTH DEPENDENT ON PRECIP C--- EFFICIENCY (EDT), NORMALIZED CONDENSATE (PWAV), AND C--- EVAPORATE (PWEV) C DO I = 1, IM edtmax = edtmaxl if(slimsk(i).eq.0.) edtmax = edtmaxs IF(DWNFLG2(I)) THEN IF(PWEVO(I).LT.0.) THEN EDTO(I) = -EDTO(I) * PWAVO(I) / PWEVO(I) if(gcmflg.and.edto(i).ge..90) then cnvflg(i) = .false. dwnflg2(i) = .false. endif EDTO(I) = MIN(EDTO(I),EDTMAX) ELSE EDTO(I) = 0. ENDIF ELSE EDTO(I) = 0. ENDIF ENDDO C C C--- DOWNDRAFT CLOUDWORK FUNCTIONS C C DO K = KMAX-1, 1, -1 DO I = 1, IM IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN GAMMA = EL2ORC * QESO(I,K) / TO(I,K)**2 DHH=HCDO(I) DT=TO(I,K) DG=GAMMA DH=HESO(I,K) DZ=-1.*(ZO(I,K+1)-ZO(I,K)) AA1(I)=AA1(I)+EDTO(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) & *(1.+FV*CP*DG*DT/HVAP) AA1(I)=AA1(I)+EDTO(I)* & DZ*G*FV*MAX(0.,(QESO(I,K)-QO(I,K))) ENDIF ENDDO ENDDO CCCCC IF(LAT.EQ.LATD.AND.DWNFLG2(LOND)) THEN CCCCC I = LOND CCCCC PRINT *, ' AA1 AFTER DWNDRFT =', AA1(I) CCCCC ENDIF ccc print*,'step j',lat DO I = 1, IM IF(AA1(I).LE.0.) CNVFLG(I) = .FALSE. IF(AA1(I).LE.0.) DWNFLG(I) = .FALSE. IF(AA1(I).LE.0.) DWNFLG2(I) = .FALSE. ENDDO C C C--- WHAT WOULD THE CHANGE BE, THAT A CLOUD WITH UNIT MASS C--- WILL DO TO THE ENVIRONMENT? C DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I)) THEN DELLAH(I,K) = 0. DELLAQ(I,K) = 0. ENDIF ENDDO ENDDO ccc print*,'step j',lat DO I = 1, IM IF(CNVFLG(I)) THEN DP = 100. * PSFC(I) * DEL(1) DELLAH(I,1) = EDTO(I) * ETAD(I,1) * (HCDO(I) & - HEO(I,1)) * G / DP DELLAQ(I,1) = EDTO(I) * ETAD(I,1) * (QCDO(I) & - QO(I,1)) * G / DP ENDIF ENDDO C C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT C ccc print*,'step j',lat DO K = 2, KMAX-1 DO I = 1, IM IF(CNVFLG(I).AND.K.LT.KTCON(I)) THEN AUP = 1. IF(K.LE.KB(I)) AUP = 0. ADW = 1. IF(K.GT.JMIN(I)) ADW = 0. DV1= HEO(I,K) DV2 = .5 * (HEO(I,K) + HEO(I,K+1)) DV3= HEO(I,K-1) DV1Q= QO(I,K) DV2Q = .5 * (QO(I,K) + QO(I,K+1)) DV3Q= QO(I,K-1) DP = 100. * PSFC(I) * DEL(K) DZ = .5 * (ZO(I,K+1) - ZO(I,K-1)) DETA = ETA(I,K) - ETA(I,K-1) DETAD = ETAD(I,K) - ETAD(I,K-1) DELLAH(I,K) = DELLAH(I,K) + & ((AUP * ETA(I,K) - ADW * EDTO(I) * ETAD(I,K)) * DV1 & - (AUP * ETA(I,K-1) - ADW * EDTO(I) * ETAD(I,K-1))* DV3 & - AUP * DETA * DV2 & + ADW * EDTO(I) * DETAD * HCDO(I)) * G / DP DELLAQ(I,K) = DELLAQ(I,K) + & ((AUP * ETA(I,K) - ADW * EDTO(I) * ETAD(I,K)) * DV1Q & - (AUP * ETA(I,K-1) - ADW * EDTO(I) * ETAD(I,K-1))* DV3Q & - AUP * DETA * DV2Q & +ADW*EDTO(I)*DETAD*.5*(QRCDO(I,K)+QRCDO(I,K-1))) * G / DP ENDIF ENDDO ENDDO C C------- CLOUD TOP C DO I = 1, IM IF(CNVFLG(I)) THEN INDX = KTCON(I) DP = 100. * PSFC(I) * DEL(INDX) DV1 = HEO(I,INDX-1) DELLAH(I,INDX) = ETA(I,INDX-1) * & (HCKO(I,INDX-1) - DV1) * G / DP DVQ1 = QO(I,INDX-1) DELLAQ(I,INDX) = ETA(I,INDX-1) * & (QCKO(I,INDX-1) - DVQ1) * G / DP ENDIF ENDDO ccc print*,'step j',lat C C------- FINAL CHANGED VARIABLE PER UNIT MASS FLUX C DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I).and.k.gt.ktcon(i)) THEN qo(I,K) = Q1(I,K) to(I,K) = T1(I,K) ENDIF IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN qo(I,K) = DELLAQ(I,K) * MBDT + Q1(I,K) DELLAT = (DELLAH(I,K) - HVAP * DELLAQ(I,K)) / CP to(I,K) = DELLAT * MBDT + T1(I,K) qo(I,K) = MAX(qo(I,K),QMIN) ENDIF ENDDO ENDDO C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C C--- THE ABOVE CHANGED ENVIRONMENT IS NOW USED TO CALULATE THE C--- EFFECT THE ARBITRARY CLOUD (WITH UNIT MASS FLUX) C--- WOULD HAVE ON THE STABILITY, C--- WHICH THEN IS USED TO CALCULATE THE REAL MASS FLUX, C--- NECESSARY TO KEEP THIS CHANGE IN BALANCE WITH THE LARGE-SCALE C--- DESTABILIZATION. C C--- ENVIRONMENTAL CONDITIONS AGAIN, FIRST HEIGHTS C DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I)) THEN qeso(I,K) = 10. * FPVS(to(I,K)) qeso(I,K) = EPS * qeso(I,K) / (P(I,K) + EPSM1 * qeso(I,K)) qeso(I,K) = MAX(qeso(I,K),QMIN) TVO(I,K) = TO(I,K) + FV * TO(I,K) * MAX(QO(I,K),QMIN) CCC IF(NCLOUD.GT.1) THEN CCC QSUM = 0. CCC DO ICLOUD = 1,NCLOUD CCC KK = K + KM * (ICLOUD-1) CCC QSUM = MAX(Q1(I,KK),QMIN) + QSUM CCC ENDDO CCC tvfac = (1.+ MAX(Q1(I,K),QMIN)) / (1.+ QSUM) CCC TVO(I,K) = TVO(I,K)*tvfac CCC ENDIF ENDIF ENDDO ENDDO ccc print*,'step j',lat DO I = 1, IM IF(CNVFLG(I)) THEN XAA0(I) = 0. XPWAV(I) = 0. ENDIF ENDDO C C HYDROSTATIC HEIGHT ASSUME ZERO TERR C DLNSIG = LOG(SL(1)) DO I = 1, IM IF(CNVFLG(I)) THEN zo(I,1) = TERR - DLNSIG * RD / G * tvo(I,1) ENDIF ENDDO DO K = 2, KMAX DLNSIG = LOG(SL(K) / SL(K-1)) DO I = 1, IM IF(CNVFLG(I)) THEN zo(I,K) = zo(I,K-1) - DLNSIG * RD / G & * .5 * (tvo(I,K) + tvo(I,K-1)) ENDIF ENDDO ENDDO C C--- MOIST STATIC ENERGY C DO K = 1, KMAX - 1 DO I = 1, IM IF(CNVFLG(I)) THEN DZ = .5 * (zo(I,K+1) - zo(I,K)) DP = .5 * (P(I,K+1) - P(I,K)) ES = 10. * FPVS(to(I,K+1)) PPRIME = P(I,K+1) + EPSM1 * ES QS = EPS * ES / PPRIME DQSDP = - QS / PPRIME DESDT = ES * (FACT1 / to(I,K+1) + FACT2 / (to(I,K+1)**2)) DQSDT = QS * P(I,K+1) * DESDT / (ES * PPRIME) GAMMA = EL2ORC * qeso(I,K+1) / (to(I,K+1)**2) DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) DQ = DQSDT * DT + DQSDP * DP to(I,K) = to(I,K+1) + DT qo(I,K) = qo(I,K+1) + DQ PO = .5 * (P(I,K) + P(I,K+1)) qeso(I,K) = 10. * FPVS(to(I,K)) qeso(I,K) = EPS * qeso(I,K) / (PO + EPSM1 * qeso(I,K)) qeso(I,K) = MAX(qeso(I,K),QMIN) C qo(I,K) = MIN(qo(I,K),qeso(I,K)) heo(I,K) = .5 * G * (zo(I,K) + zo(I,K+1)) + & CP * to(I,K) + HVAP * qo(I,K) heso(I,K) = .5 * G * (zo(I,K) + zo(I,K+1)) + & CP * to(I,K) + HVAP * qeso(I,K) ENDIF ENDDO ENDDO k = kmax do i = 1, im IF(CNVFLG(I)) THEN heo(I,K) = G * zo(I,K) + CP * to(I,K) + HVAP * qo(I,K) heso(I,K) = G * zo(I,K) + CP * to(I,K) + HVAP * qeso(I,K) c heo(I,K) = MIN(heo(I,K),heso(I,K)) ENDIF enddo DO I = 1, IM IF(CNVFLG(I)) THEN INDX = KB(I) XHKB(I) = heo(I,INDX) XQKB(I) = qo(I,INDX) hcko(I,INDX) = XHKB(I) qcko(I,INDX) = XQKB(I) ENDIF ENDDO ccc print*,'step j',lat C C C**************************** STATIC CONTROL C C C------- MOISTURE AND CLOUD WORK FUNCTIONS C DO K = 2, KMAX - 1 DO I = 1, IM C IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KTCON(I)) THEN FACTOR = ETA(I,K-1) / ETA(I,K) ONEMF = 1. - FACTOR hcko(I,K) = FACTOR * hcko(I,K-1) + ONEMF * & .5 * (heo(I,K) + heo(I,K+1)) ENDIF C IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN C heo(I,K) = heo(I,K-1) C ENDIF ENDDO ENDDO DO K = 2, KMAX - 1 DO I = 1, IM IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN DZ = .5 * (zo(I,K+1) - zo(I,K-1)) GAMMA = EL2ORC * qeso(I,K) / (to(I,K)**2) XDBY = hcko(I,K) - heso(I,K) XDBY = MAX(XDBY,0.) XQRCH = qeso(I,K) & + GAMMA * XDBY / (HVAP * (1. + GAMMA)) FACTOR = ETA(I,K-1) / ETA(I,K) ONEMF = 1. - FACTOR qcko(I,K) = FACTOR * qcko(I,K-1) + ONEMF * & .5 * (qo(I,K) + qo(I,K+1)) DQ = ETA(I,K) * qcko(I,K) - ETA(I,K) * XQRCH IF(DQ.GT.0.) THEN ETAH = .5 * (ETA(I,K) + ETA(I,K-1)) QLK = DQ / (ETA(I,K) + ETAH * C0 * DZ) XAA0(I) = XAA0(I) - (zo(I,K) - zo(I,K-1)) * G * QLK XQC = QLK + XQRCH XPW = ETAH * C0 * DZ * QLK qcko(I,K) = XQC XPWAV(I) = XPWAV(I) + XPW ENDIF ENDIF IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LT.KTCON(I)) THEN DZ1 = zo(I,K) - zo(I,K-1) GAMMA = EL2ORC * qeso(I,K-1) / (to(I,K-1)**2) RFACT = 1. + FV * CP * GAMMA & * to(I,K-1) / HVAP XDBY = hcko(I,K-1) - heso(I,K-1) XAA0(I) = XAA0(I) & + DZ1 * (G / (CP * to(I,K-1))) & * XDBY / (1. + GAMMA) & * RFACT XAA0(I)=XAA0(I)+ & DZ1 * G * FV * & MAX(0.,(qeso(I,K-1) - qo(I,K-1))) ENDIF ENDDO ENDDO ccc print*,'step j',lat CCCCC IF(LAT.EQ.LATD.AND.CNVFLG(LOND)) THEN CCCCC I = LOND CCCCC PRINT *, ' XAA BEFORE DWNDRFT =', XAA0(I) CCCCC ENDIF C C------- DOWNDRAFT CALCULATIONS C C C--- DOWNDRAFT MOISTURE PROPERTIES C DO I = 1, IM XPWEV(I) = 0. ENDDO DO I = 1, IM IF(DWNFLG2(I)) THEN JMN = JMIN(I) XHCD(I) = heo(I,JMN) XQCD(I) = qo(I,JMN) QRCD(I,JMN) = qeso(I,JMN) ENDIF ENDDO DO K = KMAX-1, 1, -1 DO I = 1, IM IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN DQ = qeso(I,K) DT = to(I,K) GAMMA = EL2ORC * DQ / DT**2 DH = XHCD(I) - heso(I,K) QRCD(I,K)=DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH DETAD = ETAD(I,K+1) - ETAD(I,K) XPWD = ETAD(I,K+1) * QRCD(I,K+1) - & ETAD(I,K) * QRCD(I,K) XPWD = XPWD - DETAD * & .5 * (QRCD(I,K) + QRCD(I,K+1)) XPWEV(I) = XPWEV(I) + XPWD ENDIF ENDDO ENDDO C DO I = 1, IM edtmax = edtmaxl if(slimsk(i).eq.0.) edtmax = edtmaxs IF(DWNFLG2(I)) THEN IF(XPWEV(I).GE.0.) THEN EDTX(I) = 0. ELSE EDTX(I) = -EDTX(I) * XPWAV(I) / XPWEV(I) if(gcmflg.and.edtx(i).ge..90) then cnvflg(i) = .false. dwnflg2(i) = .false. endif EDTX(I) = MIN(EDTX(I),EDTMAX) ENDIF ELSE EDTX(I) = 0. ENDIF ENDDO C C C C--- DOWNDRAFT CLOUDWORK FUNCTIONS C C DO K = KMAX-1, 1, -1 DO I = 1, IM IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN GAMMA = EL2ORC * qeso(I,K+1) / to(I,K+1)**2 DHH=XHCD(I) DT= to(I,K) DG= GAMMA DH= heso(I,K) DZ=-1.*(zo(I,K+1)-zo(I,K)) XAA0(I)=XAA0(I)+EDTX(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) & *(1.+FV*CP*DG*DT/HVAP) XAA0(I)=XAA0(I)+EDTX(I)* & DZ*G*FV*MAX(0.,(qeso(I,K)-qo(I,K))) ENDIF ENDDO ENDDO CCCCC IF(LAT.EQ.LATD.AND.DWNFLG2(LOND)) THEN CCCCC I = LOND CCCCC PRINT *, ' XAA AFTER DWNDRFT =', XAA0(I) CCCCC ENDIF C C CALCULATE CRITICAL CLOUD WORK FUNCTION C DO I = 1, IM ACRT(I) = 0. IF(CNVFLG(I)) THEN C IF(CNVFLG(I).AND.SLIMSK(I).NE.1.) THEN IF(P(I,KTCON(I)).LT.PCRIT(15))THEN ACRT(I)=ACRIT(15)*(975.-P(I,KTCON(I))) & /(975.-PCRIT(15)) ELSE IF(P(I,KTCON(I)).GT.PCRIT(1))THEN ACRT(I)=ACRIT(1) ELSE K = INT((850. - P(I,KTCON(I)))/50.) + 2 K = MIN(K,15) K = MAX(K,2) ACRT(I)=ACRIT(K)+(ACRIT(K-1)-ACRIT(K))* * (P(I,KTCON(I))-PCRIT(K))/(PCRIT(K-1)-PCRIT(K)) ENDIF C ELSE C ACRT(I) = .5 * (P(I,KBCON(I)) - P(I,KTCON(I))) ENDIF ENDDO DO I = 1, IM ACRTFCT(I) = 1. w1 = w1s w2 = w2s w3 = w3s w4 = w4s if(slimsk(i).eq.1.) then w1 = w1l w2 = w2l w3 = w3l w4 = w4l endif IF(CNVFLG(I)) THEN C IF(CNVFLG(I).AND.SLIMSK(I).EQ.1.) THEN C ACRTFCT(I) = PDOT(I) / W3 IF(PDOT(I).LE.W4) THEN ACRTFCT(I) = (PDOT(I) - W4) / (W3 - W4) ELSEIF(PDOT(I).GE.-W4) THEN ACRTFCT(I) = (PDOT(I) + W4) / (W4 - W3) ELSE ACRTFCT(I) = 0. ENDIF ACRTFCT(I) = MAX(ACRTFCT(I),-1.) ACRTFCT(I) = MIN(ACRTFCT(I),1.) ACRTFCT(I) = 1. - ACRTFCT(I) c DTCONV(I) = DT2 + (1800. - DT2) * c & (PDOT(I) - W2) / (W1 - W2) c DTCONV(I) = MAX(DTCONV(I), DT2) C dtconv(i) = DT2 + 1800. * (pdot(i) - w2) / (w1 - w2) dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2) dtconv(i) = max(dtconv(i),dtmin) dtconv(i) = min(dtconv(i),dtmax) ENDIF ENDDO ccc print*,'step j',lat C C--- LARGE SCALE FORCING C DO I= 1, IM FLG(I) = CNVFLG(I) IF(CNVFLG(I)) THEN CCC F(I) = AA1(I) / DTCONV(I) F(I) = (AA1(I) - ACRT(I) * ACRTFCT(I)) / DTCONV(I) IF(F(I).LE.0.) FLG(I) = .FALSE. ENDIF CNVFLG(I) = FLG(I) IF(CNVFLG(I)) THEN C XAA0(I) = MAX(XAA0(I),0.) XK(I) = (XAA0(I) - AA1(I)) / MBDT IF(XK(I).GE.0.) FLG(I) = .FALSE. ENDIF C C--- KERNEL, CLOUD BASE MASS FLUX C CNVFLG(I) = FLG(I) IF(CNVFLG(I)) THEN XMB(I) = -F(I) / XK(I) XMB(I) = MIN(XMB(I),XMBMAX(I)) ENDIF ENDDO CCCCC IF(LAT.EQ.LATD.AND.CNVFLG(LOND)) THEN CCCCC I = LOND CCCCC PRINT *, ' A1, XA =', AA1(I), XAA0(I) CCCCC PRINT *, ' XMB, ACRT =', XMB(I), ACRT(I) CCCCC ENDIF TOTFLG = .TRUE. DO I = 1, IM TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) ENDDO IF(TOTFLG) RETURN ccc print*,'step j',lat c c restore t0 and qo to t1 and q1 in case convection stops c do k = 1, kmax do i = 1, im to(i,k) = t1(i,k) qo(i,k) = q1(i,k) QESO(I,K) = 10. * FPVS(T1(I,K)) QESO(I,K) = EPS * QESO(I,K) / (P(I,K) + EPSM1 * QESO(I,K)) QESO(I,K) = MAX(QESO(I,K),QMIN) enddo enddo C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C C--- FEEDBACK: SIMPLY THE CHANGES FROM THE CLOUD WITH UNIT MASS FLUX C--- MULTIPLIED BY THE MASS FLUX NECESSARY TO KEEP THE C--- EQUILIBRIUM WITH THE LARGER-SCALE. C DO I = 1, IM DELHBAR(I) = 0. DELQBAR(I) = 0. DELTBAR(I) = 0. QCOND(I) = 0. ENDDO DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN AUP = 1. IF(K.LE.KB(I)) AUP = 0. ADW = 1. IF(K.GT.JMIN(I)) ADW = 0. DELLAT = (DELLAH(I,K) - HVAP * DELLAQ(I,K)) / CP T1(I,K) = T1(I,K) + DELLAT * XMB(I) * DT2 Q1(I,K) = Q1(I,K) + DELLAQ(I,K) * XMB(I) * DT2 DP = 100. * PSFC(I) * DEL(K) DELHBAR(I) = DELHBAR(I) + DELLAH(I,K)*XMB(I)*DP/G DELQBAR(I) = DELQBAR(I) + DELLAQ(I,K)*XMB(I)*DP/G DELTBAR(I) = DELTBAR(I) + DELLAT*XMB(I)*DP/G ENDIF ENDDO ENDDO ccc print*,'step j',lat CCCCC IF(LAT.EQ.LATD.AND.CNVFLG(LOND) ) THEN CCCCC I = LOND CCCCC PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' CCCCC PRINT *, DELHBAR(I), HVAP*DELQBAR(I), CP*DELTBAR(I) CCCCC ENDIF DO I = 1, IM DELQBAR(I) = 0. DELTBAR(I) = 0. ENDDO DO K = KMAX, 1, -1 DO I = 1, IM dellaq(i,k) = 0. IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN if(evaflg.and.slimsk(i).eq.0.) evef = evfact * edt(i) AUP = 1. IF(K.LE.KB(I)) AUP = 0. ADW = 1. IF(K.GT.JMIN(I)) ADW = 0. RN(I) = RN(I) & + (AUP * PWO(I,K) + ADW * EDTO(I) * PWDO(I,K)) & * XMB(I) * .001 * DT2 QRS(I,K) = AUP * PWO(I,K) + ADW * EDTO(I) * PWDO(I,K) QCOND(I) = EVEF * (QO(I,K) - QESO(I,K)) / (1. + EL2ORC * & QESO(I,K) / TO(I,K)**2) DP = 100. * PSFC(I) * DEL(K) IF(RN(I).GT.0..AND.QCOND(I).LE.0.) THEN QEVAP = -QCOND(I) * (1. - EXP(-.32 * SQRT(DT2 * RN(I)))) QEVAP = MIN(QEVAP, RN(I)*1000.*G/DP) Q1(I,K) = Q1(I,K) + QEVAP T1(I,K) = T1(I,K) - ELOCP * QEVAP RN(I) = RN(I) - .001 * QEVAP * DP / G DELLAT = - ELOCP*QEVAP/XMB(I)/DT2 DELLAQ(I,K) = + QEVAP/XMB(I)/DT2 ENDIF DELQBAR(I) = DELQBAR(I) + DELLAQ(I,K)*XMB(I)*DP/G DELTBAR(I) = DELTBAR(I) + DELLAT*XMB(I)*DP/G ENDIF ENDDO ENDDO ccc print*,'step j',lat CCCCC IF(LAT.EQ.LATD.AND.CNVFLG(LOND) ) THEN CCCCC I = LOND CCCCC PRINT *, ' DELLAH =' CCCCC PRINT 6003, (DELLAH(I,K)*XMB(I),K=1,KMAX) CCCCC PRINT *, ' DELLAQ =' CCCCC PRINT 6003, (HVAP*DELLAQ(I,K)*XMB(I),K=1,KMAX) CCCCC PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' CCCCC PRINT *, DELHBAR(I), HVAP*DELQBAR(I), CP*DELTBAR(I) CCCCC PRINT *, ' PRECIP =', HVAP*RN(I)*1000./DT2 CCCCC ENDIF C C PRECIPITATION RATE CONVERTED TO ACTUAL PRECIP C IN UNIT OF M INSTEAD OF KG C ccc print*,'step j',lat DO I = 1, IM IF(CNVFLG(I)) THEN C C IN THE EVENT OF UPPER LEVEL RAIN EVAPORATION AND LOWER LEVEL DOWNDRAF C MOISTENING, RN CAN BECOME NEGATIVE, IN THIS CASE, WE BACK OUT OF TH C HEATING AND THE MOISTENING C IF(RN(I).LE.0.) THEN RN(I) = 0. ELSE KTOP(I) = KTCON(I) KBOT(I) = KBCON(I) KUO(I) = 1 CLDWRK(I) = AA1(I) ENDIF ENDIF ENDDO DO K = 1, KMAX DO I = 1, IM IF(CNVFLG(I).AND.RN(I).LE.0.) THEN T1(I,K) = TO(I,K) Q1(I,K) = QO(I,K) ENDIF ENDDO ENDDO RETURN END CFPP$ NOCONCUR R CFPP$ EXPAND(FPKAP) C----------------------------------------------------------------------- SUBROUTINE SHALCV(IMX2,IMX22,KMX,DT,DEL,SI,SL,SLK,KUO,PS,Q,T) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SHALCV COMPUTES SHALLOW CONVECTIVE HEATING AND MOI C PRGMMR: PETER CAPLAN ORG: W/NMC23 DATE: 91-03-19 C C ABSTRACT: SUB-GRID-SCALE SHALLOW CONVECTIVE CLOUD PARAMETERIZATION. C THIS ROUTINE COMPUTES THE EFFECTS OF SHALLOW CONVECTION C BASED ON TIEDTKE (1984), ECMWF WORKSHOP ON CONVECTION IN C LARGE-SCALE NUMERICAL MODELS. C TAPERED K PROFILE IN CLOUD DEVELOPED BY CAPLAN AND LONG. C ORIGINALLY CODED BY R. KISTLER AND P. CAPLAN, CONVERTED TO STANDARD C FORTRAN FOR CRAY BY H.JUANG. H. PAN MODIFIED IT AND KUO91 TO C DO MSTADB AFTER COMPRESSION AND THE REST OF THE COMPUTATION C IN COMPRESSED ARRAYS. TIDY UP OF MOIST PROCESSES BY M. IREDELL. C C PROGRAM HISTORY LOG: C 91-03-19 HUA-LU PAN C 91-05-07 IREDELL ARGUMENTS CHANGED, TRIDI2 SPLIT OFF C C USAGE: CALL SHALCV(IM,KM,DT,DEL,SI,SL,SLK,KUO,PS,Q,T) C C INPUT ARGUMENT LIST: C IM - INTEGER NUMBER OF POINTS C KM - INTEGER NUMBER OF LEVELS C DT - REAL TIME STEP IN SECONDS C DEL - REAL (KM) SIGMA LAYER THICKNESS C SL - REAL (KM) SIGMA VALUES C SLK - REAL (KM) SIGMA VALUES TO THE KAPPA C PS - REAL (IM) SURFACE PRESSURE IN KILOPASCALS (CB) C Q - REAL (IM,KM) CURRENT SPECIFIC HUMIDITY IN KG/KG C T - REAL (IM,KM) CURRENT TEMPERATURE IN KELVIN C C OUTPUT ARGUMENT LIST: C Q - REAL (IM,KM) ADJUSTED SPECIFIC HUMIDITY IN KG/KG C T - REAL (IM,KM) ADJUSTED TEMPERATURE IN KELVIN C C SUBPROGRAMS CALLED: C MSTADB - COMPUTES MOIST ADIABAT AND RETURNS CLOUD VALUES C TRIDI2 - SOLVES TRIDIAGONAL MATRIX PROBLEM C C REMARKS: NONSTANDARD AUTOMATIC ARRAYS ARE USED. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ DIMENSION DEL(KMX),SI(KMX+1),SL(KMX),SLK(KMX),KUO(IMX2),PS(IMX2), & Q(IMX22,KMX),T(IMX22,KMX) C PHYSICAL PARAMETERS PARAMETER(G= 9.8000E+0 ,RD= 2.8705E+2 , & CP= 1.0046E+3 ,HVAP= 2.5000E+6 ) PARAMETER(GOCP=G/CP) C BOUNDS OF PARCEL ORIGIN PARAMETER(KLIFTL=2,KLIFTU=2) C LOCAL VARIABLES AND ARRAYS LOGICAL LSHC DIMENSION LSHC( 384 ) DIMENSION INDEX2( 384 ),KLCL( 384 ),KBOT( 384 ),KTOP( 384 ) DIMENSION PS2( 384 ), & Q2( 384 * 28 ),T2( 384 * 28 ), & AL( 384 *( 28 -1)),AD( 384 * 28 ), & AU( 384 *( 28 -1)) C HMHJ IM=IMX2 IX=IMX22 KM=KMX C----------------------------------------------------------------------- C COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION C AND MOIST STATIC INSTABILITY. DO I=1,IM LSHC(I)=.FALSE. ENDDO DO K=1,KM-1 DO I=1,IM IF(KUO(I).EQ.0) THEN ELDQ=HVAP*(Q(I,K)-Q(I,K+1)) CPDT=CP*(T(I,K)-T(I,K+1)) RTDLS=(SL(K)-SL(K+1))/SI(K+1)*RD*0.5*(T(I,K)+T(I,K+1)) DMSE=ELDQ+CPDT-RTDLS LSHC(I)=LSHC(I).OR.DMSE.GT.0. ENDIF ENDDO ENDDO N2=0 DO I=1,IM IF(LSHC(I)) THEN N2=N2+1 INDEX2(N2)=I ENDIF ENDDO IF(N2.EQ.0) RETURN DO I=1,N2 PS2(I)=PS(INDEX2(I)) ENDDO DO K=1,KM CFPP$ SELECT(VECTOR) DO I=1,N2 IK=(K-1)*N2+I Q2(IK)=Q(INDEX2(I),K) T2(IK)=T(INDEX2(I),K) ENDDO ENDDO C----------------------------------------------------------------------- C COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. C CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. CALL MSTADB(N2,KM-1,KLIFTL,KLIFTU,SL,SLK,PS2,T2,Q2, & KLCL,KBOT,KTOP,AL,AU) DO I=1,N2 KBOT(I)=KLCL(I)-1 KTOP(I)=KTOP(I)+1 LSHC(I)=.FALSE. ENDDO DO K=1,KM-1 DO I=1,N2 IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN IK=(K-1)*N2+I IKU=K*N2+I ELDQ=HVAP*(Q2(IK)-Q2(IKU)) CPDT=CP*(T2(IK)-T2(IKU)) RTDLS=(SL(K)-SL(K+1))/SI(K+1)*RD*0.5*(T2(IK)+T2(IKU)) DMSE=ELDQ+CPDT-RTDLS LSHC(I)=LSHC(I).OR.DMSE.GT.0. AU(IK)=G/RTDLS ENDIF ENDDO ENDDO K1=KM+1 K2=0 DO I=1,N2 IF(.NOT.LSHC(I)) THEN KBOT(I)=KM+1 KTOP(I)=0 ENDIF K1=MIN(K1,KBOT(I)) K2=MAX(K2,KTOP(I)) ENDDO KT=K2-K1+1 IF(KT.LT.2) RETURN C----------------------------------------------------------------------- C SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. C COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. C EXPAND FINAL FIELDS. DO I=1,N2 IK=(K1-1)*N2+I AD(IK)=1. ENDDO DTODSU=2.*DT/DEL(K1) DO K=K1,K2-1 DTODSL=DTODSU DTODSU=2.*DT/DEL(K+1) DSIG=SL(K)-SL(K+1) DO I=1,N2 IK=(K-1)*N2+I IKU=K*N2+I IF(K.EQ.KBOT(I)) THEN CK=1.5 ELSEIF(K.EQ.KTOP(I)-1) THEN CK=1. ELSEIF(K.EQ.KTOP(I)-2) THEN CK=3. ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN CK=5. ELSE CK=0. ENDIF DSDZ1=CK*DSIG*AU(IK)*GOCP DSDZ2=CK*DSIG*AU(IK)*AU(IK) AU(IK)=-DTODSL*DSDZ2 AL(IK)=-DTODSU*DSDZ2 AD(IK)=AD(IK)-AU(IK) AD(IKU)=1.-AL(IK) T2(IK)=T2(IK)+DTODSL*DSDZ1 T2(IKU)=T2(IKU)-DTODSU*DSDZ1 ENDDO ENDDO IK1=(K1-1)*N2+1 CALL TRIDI2(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), & AU(IK1),Q2(IK1),T2(IK1)) DO K=K1,K2 CFPP$ SELECT(VECTOR) DO I=1,N2 IK=(K-1)*N2+I Q(INDEX2(I),K)=Q2(IK) T(INDEX2(I),K)=T2(IK) ENDDO ENDDO C----------------------------------------------------------------------- RETURN END C----------------------------------------------------------------------- SUBROUTINE SICDIF(D,T,Q,X,Y,Z,U,V) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SICDIF SEMI-IMPLICIT TIME INTEGRATION. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 89-03-15 C C ABSTRACT: INTEGRATES DIVERGENCE, TEMPERATURE AND LOG SURFACE PRESSURE C SEMI-IMPLICITLY IN TIME. C C PROGRAM HISTORY LOG: C 89-03-15 JOSEPH SELA C 93-03-15 MARK IREDELL LINEAR MATRICES PASSED IN COMMON C C USAGE: CALL SICDIF(D,T,Q,X,Y,Z,U,V) C INPUT ARGUMENT LIST: C D - DIVERGENCE AT TIME T-DT C T - TEMPERATURE AT TIME T-DT C Q - LN(PSFC) AT TIME T-DT C X - DIVERGENCE NONLINEAR TENDENCY AT TIME T C Y - TEMPERATURE NONLINEAR TENDENCY AT TIME T C Z - LN(PSFC) NONLINEAR TENDENCY AT TIME T C C OUTPUT ARGUMENT LIST: C X - DIVERGENCE AT TIME T+DT C Y - TEMPERATURE AT TIME T+DT C Z - LN(PSFC) AT TIME T+DT C U - WORK ARRAY C V - WORK ARRAY C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ PARAMETER(KM= 28 ,JCAP= 62 ,LNT2= 4032 ,LNT22= 4033 ) REAL D(LNT22,KM),T(LNT22,KM),Q(LNT22) REAL X(LNT22,KM),Y(LNT22,KM),Z(LNT22),U(LNT22,KM),V(LNT22,KM) COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB COMMON/COMSIC/ DT,GVDT(KM),SVDT(KM),AMDT(KM,KM),BMDT(KM,KM), 1 DM(KM,KM,0:JCAP) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C EXPLICITLY INTEGRATE LNPS AND TEMPERATURE HALFWAY IN TIME. DO I=1,LNT2 Z(I)=Q(I)+DT*Z(I) ENDDO DO K=1,KM DO I=1,LNT2 Y(I,K)=T(I,K)+DT*Y(I,K) ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C COMPUTE LINEAR DEPENDENCE OF DIVERGENCE ON LNPS AND TEMPERATURE. C EXPLICITLY INTEGRATE DIVERGENCE HALFWAY INCLUDING LINEAR TERMS. CMIC$ DO ALL AUTOSCOPE DO K=1,KM DO I=1,LNT2 V(I,K)=0. ENDDO CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2 V(I,K)=V(I,K)+AMDT(K,J)*Y(I,J) ENDDO ENDDO DO I=1,LNT2 U(I,K)=D(I,K)+DT*X(I,K)+SNNP1(I)*(V(I,K)+GVDT(K)*Z(I)) ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C SOLVE HELMHOLZ EQUATION FOR SEMI-IMPLICIT DIVERGENCE. CMIC$ DO ALL AUTOSCOPE DO K=1,KM DO I=1,LNT2 V(I,K)=0. ENDDO CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2,2 N=NDEX(I) V(I,K)=V(I,K)+DM(K,J,N)*U(I,J) V(I+1,K)=V(I+1,K)+DM(K,J,N)*U(I+1,J) ENDDO ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C BACK SOLVE FOR LNPS. CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2 Z(I)=Z(I)+SVDT(J)*V(I,J) ENDDO ENDDO DO I=1,LNT2 Z(I)=2*Z(I)-Q(I) ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C BACK SOLVE FOR TEMPERATURE AND DIVERGENCE. CMIC$ DO ALL AUTOSCOPE DO K=1,KM CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2 Y(I,K)=Y(I,K)+BMDT(K,J)*V(I,J) ENDDO ENDDO DO I=1,LNT2 Y(I,K)=2*Y(I,K)-T(I,K) X(I,K)=2*V(I,K)-D(I,K) ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- SUBROUTINE IMPADJ(D,T,Q,X,Y,Z,U,V) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: IMPADJ IMPLICIT ADJUSTMENT OF PHYSICS TENDENCIES. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-03-15 C C ABSTRACT: EXTENDS THE SEMI-IMPLICIT TIME INTEGRATION TO INCLUDE C THE PHYICAL FORCING TERMS COMPUTED IN GLOOPB. C C PROGRAM HISTORY LOG: C 91-03-15 MARK IREDELL C 93-03-15 MARK IREDELL CHANGE ARGUMENT LIST C C USAGE: CALL IMPADJ(D,T,Q,X,Y,Z,U,V) C INPUT ARGUMENT LIST: C D - DIVERGENCE BEFORE ADJUSTMENT C T - TEMPERATURE BEFORE ADJUSTMENT C Q - LN(PSFC) BEFORE ADJUSTMENT C X - DIVERGENCE TENDENCY ADJUSTMENT C Y - TEMPERATURE TENDENCY ADJUSTMENT C Z - LN(PSFC) TENDENCY ADJUSTMENT C C OUTPUT ARGUMENT LIST: C D - DIVERGENCE ADJUSTED C T - TEMPERATURE ADJUSTED C Q - LN(PSFC) ADJUSTED C U - WORK ARRAY C V - WORK ARRAY C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ PARAMETER(KM= 28 ,JCAP= 62 ,LNT2= 4032 ,LNT22= 4033 ) REAL D(LNT22,KM),T(LNT22,KM),Q(LNT22) REAL X(LNT22,KM),Y(LNT22,KM),Z(LNT22),U(LNT22,KM),V(LNT22,KM) COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB COMMON/COMSIC/ DT,GVDT(KM),SVDT(KM),AMDT(KM,KM),BMDT(KM,KM), 1 DM(KM,KM,0:JCAP) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C COMPUTE LINEAR DEPENDENCE OF DIVERGENCE ON LNPS AND TEMPERATURE. CMIC$ DO ALL AUTOSCOPE DO K=1,KM DO I=1,LNT2 V(I,K)=0. ENDDO CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2 V(I,K)=V(I,K)+AMDT(K,J)*Y(I,J) ENDDO ENDDO DO I=1,LNT2 U(I,K)=X(I,K)+SNNP1(I)*(V(I,K)+GVDT(K)*Z(I)) ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C SOLVE HELMHOLZ EQUATION FOR SEMI-IMPLICIT DIVERGENCE. CMIC$ DO ALL AUTOSCOPE DO K=1,KM DO I=1,LNT2 V(I,K)=0. ENDDO CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2,2 N=NDEX(I) V(I,K)=V(I,K)+DM(K,J,N)*U(I,J) V(I+1,K)=V(I+1,K)+DM(K,J,N)*U(I+1,J) ENDDO ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C BACK SOLVE FOR LNPS. CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2 Q(I)=Q(I)+SVDT(J)*V(I,J) ENDDO ENDDO DO I=1,LNT2 Q(I)=Q(I)+Z(I) ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C BACK SOLVE FOR TEMPERATURE AND DIVERGENCE. CMIC$ DO ALL AUTOSCOPE DO K=1,KM CFPP$ UNROLL L DO J=1,KM DO I=1,LNT2 T(I,K)=T(I,K)+BMDT(K,J)*V(I,J) ENDDO ENDDO DO I=1,LNT2 T(I,K)=T(I,K)+Y(I,K) D(I,K)=D(I,K)+V(I,K) ENDDO ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- SUBROUTINE GSICDF(DELTIM,AM,BM,GV,SV,CM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GSICDF SETUP FOR SEMI-IMPLICIT TIME INTEGRATION. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 89-03-15 C C ABSTRACT: COMPUTES MATRIX INVERSE OF RHS DIVERGENCE AUTODEPENDENCE C IN THE SEMI-IMPLICIT TREATMENT OF THE GRAVITY WAVE MODES. C C PROGRAM HISTORY LOG: C 93-03-15 MARK IREDELL C C USAGE: CALL GSICDF(DELTIM,AM,BM,GV,SV,CM) C INPUT ARGUMENT LIST: C DELTIM - TIMESTEP C AM - DIV DEPENDENCE ON TEMP (HYDROSTATIC) C BM - TEMP DEPENDENCE ON DIV (ENERGY CONVERSION) C GV - DIV DEPENDENCE ON LNPS (PRESSURE GRADIENT) C SV - LNPS DEPENDENCE ON DIV (CONTINUITY) C CM - DIV AUTODEPENDENCE (CM=SV*GV+AM*BM) C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ PARAMETER(KM= 28 ,JCAP= 62 ,LNT2= 4032 ) DIMENSION AM(KM*KM),BM(KM*KM),SV(KM),GV(KM),CM(KM*KM) PARAMETER(RD= 2.8705E+2 ,RERTH= 6.3712E+6 ,RAA=RD/(RERTH**2)) PARAMETER(TOL=1.E-12) COMMON/COMSIC/ DT,GVDT(KM),SVDT(KM),AMDT(KM*KM),BMDT(KM*KM), 1 DM(KM*KM,0:JCAP) C-CRA DIMENSION WORK(2*KM) DIMENSION IWORK(2*KM) C-T90 DIMENSION IWORK(2*KM) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DT=DELTIM DO K=1,KM GVDT(K)=DT*GV(K) SVDT(K)=DT*SV(K) ENDDO DO KJ=1,KM*KM AMDT(KJ)=DT*AM(KJ) BMDT(KJ)=DT*BM(KJ) DM(KJ,0)=0. ENDDO DO KJ=1,KM*KM,KM+1 DM(KJ,0)=1. ENDDO C$DOACROSS SHARE(DT,DM,CM), C$& LOCAL(N,DT2NN1,KJ,WORK,IWORK,DET) CMIC$ DO ALL SHARED(DT,DM,CM) PRIVATE(N,DT2NN1,KJ,WORK,IWORK,DET) DO N=1,JCAP DT2NN1=DT**2*(N*(N+1)) DO KJ=1,KM*KM DM(KJ,N)=DM(KJ,0)-DT2NN1*CM(KJ) ENDDO C-T90 IF(1.EQ.1) THEN C-T90 CALL IMINV(DM(1,N),KM,DET,IWORK(1),IWORK(KM+1)) C-T90 ELSE C-CRA CALL MINV(DM(1,N),KM,KM,WORK,DET,TOL,0,1) C-T90 ENDIF CALL IMINV(DM(1,N),KM,DET,IWORK(1),IWORK(KM+1)) ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END SUBROUTINE SETSIG(CI, SI, DEL, SL, CL, RPI, NSG) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SETSIG SETS UP MODEL SIGMA STRUCTURE. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-05 C C ABSTRACT: SETS UP MODEL SIGMA STRUCTURE BASED ON VERTICAL C SIGMA SPACING DEFINED IN THE SUBROUTINE. C C PROGRAM HISTORY LOG: C 88-04-05 JOSEPH SELA C C USAGE: CALL SETSIG (CI, SI, DEL, SL, CL, RPI) C C OUTPUT ARGUMENT LIST: C CI - ARRAY OF 1.0-SI AT EACH LEVEL. C SI - ARRAY OF SIGMA VALUE AT EACH LEVEL. C DEL - ARRAY OF SIGMA SPACING AT EACH LAYER. C SL - ARRAY OF SIGMA AT MIDPOINT OF SIGMA LAYERS. C CL - ARRAY OF 1.0-SL AT EACH LAYER MIDPOINT. C RPI - ARRAY OF PI RATIOS NEEDED IN THERMODYNAMIC EQUATION. C C OUTPUT FILES: C OUTPUT - PRINTOUT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ REAL RK,RK1,RKR DIMENSION CI( 29 ), SI( 29 ), 1 DEL( 28 ), SL( 28 ), CL( 28 ), RPI( 27 ) INTEGER IDATE(4) C PRINT 98, NSG 98 FORMAT (1H0, 'BEGIN SETSIG - GETTING SIGS FROM UNIT',I4) REWIND NSG READ(NSG) READ(NSG) FHOUR,IDATE,SI,SL REWIND NSG DO 1 LI=1, 29 1 CI(LI) = 1. E 0 - SI(LI) DO 3 LE=1, 28 CL(LE) = 1. E 0 - SL(LE) DEL(LE) = SI(LE) - SI(LE+1) 3 CONTINUE C COMPUTE PI RATIOS FOR TEMP. MATRIX. RK = 2.8705E+2 / 1.0046E+3 DO 4 LE=1, 27 BASE = SL(LE+1)/SL(LE) 4 RPI(LE) = BASE**RK DO 5 LE=1, 29 PRINT 100, LE, CI(LE), SI(LE) 100 FORMAT (1H , 'LEVEL=', I2, 2X, 'CI=', F6.3, 2X, 'SI=', F6.3) 5 CONTINUE PRINT 97 97 FORMAT (1H0) DO 6 LE=1, 28 PRINT 101, LE, CL(LE), SL(LE), DEL(LE) 101 FORMAT (1H , 'LAYER=', I2, 2X, 'CL=', F6.3, 2X, 'SL=', F6.3, 2X, 1 'DEL=', F6.3) 6 CONTINUE PRINT 102, (RPI(LE), LE=1, 27 ) 102 FORMAT (1H0, 'RPI=', (18(1X,F6.3)) ) RETURN END CFPP$ NOCONCUR R SUBROUTINE SUMS2I(FLN,AP,QLN,LEVS) PARAMETER (LEN0= 192 ) PARAMETER (LENH= 192 /2) PARAMETER (LNT= 2016 ) PARAMETER (LNT22= 4033 ) PARAMETER (JCAP= 62 ) DIMENSION AP(2,0:LEN0,LEVS), QLN(2*LNT), FLN(LNT22,LEVS) C C LOCAL SCALARS C ------------- C INTEGER I, N, L, K REAL EVENR, EVENI C C STATEMENT FUNCTIONS C ------------------- C C OFFSET(N,L) IS THE OFFSET IN WORDS C TO THE (N,L)-ELEMENT OF A LOWER C TRIANGULAR MATRIX OF COMPLEX NUMBERS C IN AN ARRAY CONTAINING THE MATRIX C PACKED IN COLUMN-MAJOR ORDER, C WHERE L AND N RANGE FROM 0 TO JCAP, C INCLUSIVE C C LOWER TRIANGULAR MATRIX OF COMPLEX NUMBERS: C C L --> C C X C N X X C X X X C | X X X X C V X X X X X C X X X X X X C C ORDER OF THE MATRIX ELEMENTS IN MEMORY: C C (0,0), (1,0), (2,0), ..., (JCAP,0), (1,1), (2,1), (3,1), ... C INTEGER OFFSET OFFSET(N,L) = (JCAP+1)*(JCAP+2) - (JCAP-L+1)*(JCAP-L+2) + 2*(N-L) C C --- C C TERM(1,N,L,K) AND TERM(2,N,L,K) ARE C THE REAL AND IMAGINARY PART, RESP., C OF EXP((0,1)*L*PHI) TIMES THE (N,L) TERM C IN THE EXPANSION IN SPHERICAL C HARMONICS OF THE FIELD AT LEVEL K, C WHERE PHI IS THE AZIMUTHAL ANGLE C TERM(I,N,L,K) = QLN(OFFSET(N,L)+I)*FLN(OFFSET(N,L)+I,K) C C ZERO THE ACCUMULATORS C --------------------- C DO K = 1, LEVS DO L = 0, JCAP AP(1,L,K) = 0. AP(2,L,K) = 0. AP(1,LENH+L,K) = 0. AP(2,LENH+L,K) = 0. END DO END DO C C COMPUTE THE EVEN AND ODD (N-L) COMPONENTS C OF THE FOURIER COEFFICIENTS C --------------------------------------------------------- C CFPP$ CNCALL DO L = 0, JCAP CCCCCCCCCCCCCCCCCCCCCCCCCCCCC C-CRA LS=L*((2*JCAP+3)-L) C C COMPUTE THE SUM OF THE EVEN (N-L) TERMS FOR EACH LEVEL C ------------------------------------------------------ C C REAL PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+2-L)/2,1.,FLN(LS+1,1),LNT22,4, C-CRA1 QLN(LS+1),4,1.,AP(1,L,1),(LEN0+1)*2) C DO N = L, JCAP, 2 DO K = 1, LEVS AP(1,L,K) = AP(1,L,K) + TERM(1,N,L,K) END DO END DO C C IMAGINARY PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+2-L)/2,1.,FLN(LS+2,1),LNT22,4, C-CRA1 QLN(LS+2),4,1.,AP(2,L,1),(LEN0+1)*2) C DO N = L, JCAP, 2 DO K = 1, LEVS AP(2,L,K) = AP(2,L,K) + TERM(2,N,L,K) END DO END DO C C COMPUTE THE SUM OF THE ODD (N-L) TERMS FOR EACH LEVEL C ----------------------------------------------------- C-CRA IF(L.LT.JCAP) THEN C C REAL PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+1-L)/2,1.,FLN(LS+3,1),LNT22,4, C-CRA1 QLN(LS+3),4,1.,AP(1,LENH+L,1),(LEN0+1)*2) C DO N = L+1, JCAP, 2 DO K = 1, LEVS AP(1,LENH+L,K) = AP(1,LENH+L,K) + TERM(1,N,L,K) END DO END DO C C IMAGINARY PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+1-L)/2,1.,FLN(LS+4,1),LNT22,4, C-CRA1 QLN(LS+4),4,1.,AP(2,LENH+L,1),(LEN0+1)*2) C DO N = L+1, JCAP, 2 DO K = 1, LEVS AP(2,LENH+L,K) = AP(2,LENH+L,K) + TERM(2,N,L,K) END DO END DO C C-CRA ENDIF CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcc END DO C C C COMPUTE THE FOURIER COEFFICIENTS FOR EACH LEVEL C ----------------------------------------------- C DO K = 1, LEVS DO L = 0, JCAP EVENR = AP(1,L,K) EVENI = AP(2,L,K) AP(1,L,K) = AP(1,L,K) + AP(1,LENH+L,K) AP(2,L,K) = AP(2,L,K) + AP(2,LENH+L,K) AP(1,LENH+L,K) = EVENR - AP(1,LENH+L,K) AP(2,LENH+L,K) = EVENI - AP(2,LENH+L,K) END DO END DO C RETURN END CFPP$ NOCONCUR R SUBROUTINE SUMS2R(FLN,AP,QLN,LEVS) PARAMETER (LEN0= 192 ) PARAMETER (LENH= 192 /2) PARAMETER (LNT= 2016 ) PARAMETER (LNT22= 4033 ) PARAMETER (JCAP= 62 ) DIMENSION AP(2,0:LEN0,LEVS), QLN(2*LNT), FLN(LNT22,LEVS) C C LOCAL SCALARS C ------------- C INTEGER I, N, L, K REAL EVENR, EVENI C C STATEMENT FUNCTIONS C ------------------- C C OFFSET(N,L) IS THE OFFSET IN WORDS C TO THE (N,L)-ELEMENT OF A LOWER C TRIANGULAR MATRIX OF COMPLEX NUMBERS C IN AN ARRAY CONTAINING THE MATRIX C PACKED IN COLUMN-MAJOR ORDER, C WHERE L AND N RANGE FROM 0 TO JCAP, C INCLUSIVE C C LOWER TRIANGULAR MATRIX OF COMPLEX NUMBERS: C C L --> C C X C N X X C X X X C | X X X X C V X X X X X C X X X X X X C C ORDER OF THE MATRIX ELEMENTS IN MEMORY: C C (0,0), (1,0), (2,0), ..., (JCAP,0), (1,1), (2,1), (3,1), ... C INTEGER OFFSET OFFSET(N,L) = (JCAP+1)*(JCAP+2) - (JCAP-L+1)*(JCAP-L+2) + 2*(N-L) C C --- C C TERM(1,N,L,K) AND TERM(2,N,L,K) ARE C THE REAL AND IMAGINARY PART, RESP., C OF EXP((0,1)*L*PHI) TIMES THE (N,L) TERM C IN THE EXPANSION IN SPHERICAL C HARMONICS OF THE FIELD AT LEVEL K, C WHERE PHI IS THE AZIMUTHAL ANGLE C TERM(I,N,L,K) = QLN(OFFSET(N,L)+I)*FLN(OFFSET(N,L)+I,K) C C ZERO THE ACCUMULATORS C --------------------- C DO K = 1, LEVS DO L = 0, JCAP AP(1,L,K) = 0. AP(2,L,K) = 0. AP(1,LENH+L,K) = 0. AP(2,LENH+L,K) = 0. END DO END DO C C COMPUTE THE EVEN AND ODD (N-L) COMPONENTS C OF THE FOURIER COEFFICIENTS C --------------------------------------------------------- C CFPP$ CNCALL DO L = 0, JCAP CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C-CRA LS=L*((2*JCAP+3)-L) C C COMPUTE THE SUM OF THE EVEN (N-L) TERMS FOR EACH LEVEL C ------------------------------------------------------ C C REAL PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+2-L)/2,1.,FLN(LS+1,1),LNT22,4, C-CRA1 QLN(LS+1),4,1.,AP(1,L,1),(LEN0+1)*2) C DO N = L, JCAP, 2 DO K = 1, LEVS AP(1,L,K) = AP(1,L,K) + TERM(1,N,L,K) END DO END DO C C IMAGINARY PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+2-L)/2,1.,FLN(LS+2,1),LNT22,4, C-CRA1 QLN(LS+2),4,1.,AP(2,L,1),(LEN0+1)*2) C DO N = L, JCAP, 2 DO K = 1, LEVS AP(2,L,K) = AP(2,L,K) + TERM(2,N,L,K) END DO END DO C C COMPUTE THE SUM OF THE ODD (N-L) TERMS FOR EACH LEVEL C ----------------------------------------------------- C-CRA IF(L.LT.JCAP) THEN C C REAL PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+1-L)/2,1.,FLN(LS+3,1),LNT22,4, C-CRA1 QLN(LS+3),4,1.,AP(1,LENH+L,1),(LEN0+1)*2) C DO N = L+1, JCAP, 2 DO K = 1, LEVS AP(1,LENH+L,K) = AP(1,LENH+L,K) + TERM(1,N,L,K) END DO END DO C C IMAGINARY PART C C-CRA CALL SGEMVX1(LEVS,(JCAP+1-L)/2,1.,FLN(LS+4,1),LNT22,4, C-CRA1 QLN(LS+4),4,1.,AP(2,LENH+L,1),(LEN0+1)*2) C DO N = L+1, JCAP, 2 DO K = 1, LEVS AP(2,LENH+L,K) = AP(2,LENH+L,K) + TERM(2,N,L,K) END DO END DO C C-CRA ENDIF CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC END DO C C C COMPUTE THE FOURIER COEFFICIENTS FOR EACH LEVEL C ----------------------------------------------- C DO K = 1, LEVS DO L = 0, JCAP EVENR = AP(1,L,K) EVENI = AP(2,L,K) AP(1,L,K) = AP(1,L,K) + AP(1,LENH+L,K) AP(2,L,K) = AP(2,L,K) + AP(2,LENH+L,K) AP(1,LENH+L,K) = EVENR - AP(1,LENH+L,K) AP(2,LENH+L,K) = EVENI - AP(2,LENH+L,K) END DO END DO C RETURN END SUBROUTINE FL2I(FP,FM,FLN,QLN,LEVS) PARAMETER (LEN0P= 62 ) PARAMETER (LEN0M= 62 ) PARAMETER (LNT= 2016 ) PARAMETER (LNT22= 4033 ) PARAMETER (JCAP= 62 ) DIMENSION FP(2,0:LEN0P,LEVS), FM(2,0:LEN0M,LEVS), . QLN(2*LNT), FLN(LNT22,LEVS) C C LOCAL SCALARS C ------------- C INTEGER N, L, K C C STATEMENT FUNCTION C ------------------ C C OFFSET(N,L) IS THE OFFSET IN WORDS C TO THE (N,L)-ELEMENT OF A LOWER C TRIANGULAR MATRIX OF COMPLEX NUMBERS C IN AN ARRAY CONTAINING THE MATRIX C PACKED IN COLUMN-MAJOR ORDER, C WHERE L AND N RANGE FROM 0 TO JCAP, C INCLUSIVE C C LOWER TRIANGULAR MATRIX OF COMPLEX NUMBERS: C C L --> C C X C N X X C X X X C | X X X X C V X X X X X C X X X X X X C C ORDER OF THE MATRIX ELEMENTS IN MEMORY: C C (0,0), (1,0), (2,0), ..., (JCAP,0), (1,1), (2,1), (3,1), ... C INTEGER OFFSET OFFSET(N,L) = (JCAP+1)*(JCAP+2) - (JCAP+1-L)*(JCAP+2-L) + 2*(N-L) C C ---------------------------------------------------------------- C COMPUTE THE COEFFICIENTS OF THE EXPANSION IN SPHERICAL HARMONICS C OF THE FIELD AT EACH LEVEL C ---------------------------------------------------------------- C CFPP$ CNCALL DO L = 0, JCAP CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C-CRA LS=L*((2*JCAP+3)-L) C C COMPUTE THE EVEN (N-L) EXPANSION COEFFICIENTS FOR EACH LEVEL C ------------------------------------------------------------ C C REAL PART C C-CRA CALL SGERX1((JCAP+2-L)/2,LEVS,1.,QLN(LS+1),4, C-CRA1 FP(1,L,1),(LEN0P+1)*2,FLN(LS+1,1),4,LNT22) C DO N = L, JCAP, 2 DO K = 1, LEVS FLN(OFFSET(N,L)+1,K) = FLN(OFFSET(N,L)+1,K) 1 + FP(1,L,K)*QLN(OFFSET(N,L)+1) END DO END DO C C IMAGINARY PART C C-CRA CALL SGERX1((JCAP+2-L)/2,LEVS,1.,QLN(LS+2),4, C-CRA1 FP(2,L,1),(LEN0P+1)*2,FLN(LS+2,1),4,LNT22) C DO N = L, JCAP, 2 DO K = 1, LEVS FLN(OFFSET(N,L)+2,K) = FLN(OFFSET(N,L)+2,K) 1 + FP(2,L,K)*QLN(OFFSET(N,L)+2) END DO END DO C C COMPUTE THE ODD (N-L) EXPANSION COEFFICIENTS FOR EACH LEVEL C ----------------------------------------------------------- C-CRA IF(L.LT.JCAP) THEN C C REAL PART C C-CRA CALL SGERX1((JCAP+1-L)/2,LEVS,1.,QLN(LS+3),4, C-CRA1 FM(1,L,1),(LEN0M+1)*2,FLN(LS+3,1),4,LNT22) C DO N = L+1, JCAP, 2 DO K = 1, LEVS FLN(OFFSET(N,L)+1,K) = FLN(OFFSET(N,L)+1,K) 1 + FM(1,L,K)*QLN(OFFSET(N,L)+1) END DO END DO C C IMAGINARY PART C C-CRA CALL SGERX1((JCAP+1-L)/2,LEVS,1.,QLN(LS+4),4, C-CRA1 FM(2,L,1),(LEN0M+1)*2,FLN(LS+4,1),4,LNT22) C DO N = L+1, JCAP, 2 DO K = 1, LEVS FLN(OFFSET(N,L)+2,K) = FLN(OFFSET(N,L)+2,K) 1 + FM(2,L,K)*QLN(OFFSET(N,L)+2) END DO END DO C C-CRA ENDIF CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC END DO C RETURN END CFPP$ NOCONCUR R SUBROUTINE SUMTOP(AP,TOP,QVV,KLIL,LEN0,LENH) CC PARAMETER ( LEV2P1 = 2* 28 +1 ) CC DIMENSION AP(2,0:LEN0,KLIL) CC DIMENSION TOP(2,0: 62 ,KLIL) DIMENSION EV(2,0: 62 ,LEV2P1) DIMENSION OD(2,0: 62 ,LEV2P1) CC DIMENSION QTOP(2,0: 62 ) CC DIMENSION QVV( 4158 ) CC CC CC LEN=2* 63 J=LEN+1 DO 10 L=0, 62 QTOP(1,L) = QVV(J) QTOP(2,L) = QVV(J+1) J=LEN+J LEN=LEN-2 10 CONTINUE CC CC CC DO 24 K=1,KLIL DO 22 L=0, 62 EV(1,L,K) = 0.0 EV(2,L,K) = 0.0 OD(1,L,K) = 0.0 OD(2,L,K) = 0.0 22 CONTINUE 24 CONTINUE CC CC CC CC ODD C C DO 50 L=0, 63 ,2 C ODD WAVENUMBER DO 50 L=MOD( 62 ,2), 62 ,2 CC CC REAL DO 30 K=1,KLIL OD(1,L,K) = TOP(1,L,K) * QTOP(1,L) 30 CONTINUE CC CC IMAGINARY DO 40 K=1,KLIL OD(2,L,K) = TOP(2,L,K) * QTOP(2,L) 40 CONTINUE CC 50 CONTINUE CC CC CC CC EVEN C DO 150 L=1, 62 ,2 C ODD WAVENUMBER DO 150 L=MOD( 63 ,2), 62 ,2 CC CC REAL DO 130 K=1,KLIL EV(1,L,K) = TOP(1,L,K) * QTOP(1,L) 130 CONTINUE CC CC IMAGINARY DO 140 K=1,KLIL EV(2,L,K) = TOP(2,L,K) * QTOP(2,L) 140 CONTINUE CC 150 CONTINUE CC CC CC DO 250 K=1,KLIL DO 240 L=0, 62 AP(1,L,K) = AP(1,L,K) + EV(1,L,K) + OD(1,L,K) AP(2,L,K) = AP(2,L,K) + EV(2,L,K) + OD(2,L,K) CC AP(1,L+LENH,K) = AP(1,L+LENH,K) + EV(1,L,K) - OD(1,L,K) AP(2,L+LENH,K) = AP(2,L+LENH,K) + EV(2,L,K) - OD(2,L,K) 240 CONTINUE 250 CONTINUE CC RETURN END SUBROUTINE DZUVLE(D,Z,U,V,UTOP,VTOP) PARAMETER (JCAP= 62 ) PARAMETER (LNT22=(JCAP+1)*(JCAP+2)+1) PARAMETER (LNEP=(JCAP+2)*(JCAP+3)/2) DIMENSION D(LNT22, 28 ),Z(LNT22, 28 ) DIMENSION U(LNT22, 28 ),V(LNT22, 28 ) DIMENSION UTOP(2,JCAP+1, 28 ) DIMENSION VTOP(2,JCAP+1, 28 ) DIMENSION E(LNEP) C SAVE E, IFIRST C C ARRAY E =EPS/N C ARRAY E =EPS/N C EPS/N=0. FOR N=L C ARRAY E =EPS/N C ARRAY E =EPS/N C JE(N,L) =((JCAP+2)*(JCAP+3)-(JCAP+2-L)*(JCAP+3-L))/2+N-L C JC(N,L) = (JCAP+1)*(JCAP+2)-(JCAP+1-L)*(JCAP+2-L)+2*(N-L) C DATA IFIRST/1/ IF(IFIRST.NE.1)GO TO 280 C DO 220 L=0,JCAP N=L E(JE(N,L)+1)=0. 220 CONTINUE DO 260 L= 0,JCAP DO 240 N=L+1,JCAP+1 RN=N RL=L A=(RN*RN-RL*RL)/(4.*RN*RN-1.) E(JE(N,L)+1)=SQRT(A) / RN 240 CONTINUE 260 CONTINUE IFIRST=0 280 CONTINUE C C$DOACROSS SHARE(D,Z,U,V,UTOP,VTOP,E), C$& LOCAL(K,L,N,RL,RN,J) CMIC$ DO ALL CMIC$1 SHARED(D,Z,U,V,UTOP,VTOP,E) CMIC$1 PRIVATE(K,L,N,RL,RN,J) DO 10000 K=1, 28 L=0 DO 320 N=0,JCAP C U(L,N)=-I*L*D(L,N)/(N*(N+1)) C U(JC(N,L)+1,K)=0.0 U(JC(N,L)+2,K)=0.0 C V(JC(N,L)+1,K)=0.0 V(JC(N,L)+2,K)=0.0 320 CONTINUE C DO 440 L=1,JCAP RL=L DO 420 N=L,JCAP RN=N C U(L,N)=-I*L*D(L,N)/(N*(N+1)) C U(JC(N,L)+2,K)=-RL*D(JC(N,L)+1,K)/(RN*(RN+1.)) U(JC(N,L)+1,K)= RL*D(JC(N,L)+2,K)/(RN*(RN+1.)) C V(JC(N,L)+2,K)=-RL*Z(JC(N,L)+1,K)/(RN*(RN+1.)) V(JC(N,L)+1,K)= RL*Z(JC(N,L)+2,K)/(RN*(RN+1.)) 420 CONTINUE 440 CONTINUE C DO 540 L= 0,JCAP-1 DO 520 N=L+1,JCAP U(JC(N,L)+1,K)=U(JC(N,L)+1,K)-E(JE(N,L)+1)*Z(JC(N,L)-1,K) U(JC(N,L)+2,K)=U(JC(N,L)+2,K)-E(JE(N,L)+1)*Z(JC(N,L) ,K) C V(JC(N,L)+1,K)=V(JC(N,L)+1,K)+E(JE(N,L)+1)*D(JC(N,L)-1,K) V(JC(N,L)+2,K)=V(JC(N,L)+2,K)+E(JE(N,L)+1)*D(JC(N,L) ,K) 520 CONTINUE 540 CONTINUE C DO 640 L=0,JCAP-1 DO 620 N=L,JCAP-1 U(JC(N,L)+1,K)=U(JC(N,L)+1,K)+E(JE(N+1,L)+1)*Z(JC(N,L)+3,K) U(JC(N,L)+2,K)=U(JC(N,L)+2,K)+E(JE(N+1,L)+1)*Z(JC(N,L)+4,K) C V(JC(N,L)+1,K)=V(JC(N,L)+1,K)-E(JE(N+1,L)+1)*D(JC(N,L)+3,K) V(JC(N,L)+2,K)=V(JC(N,L)+2,K)-E(JE(N+1,L)+1)*D(JC(N,L)+4,K) 620 CONTINUE 640 CONTINUE C N=JCAP+1 DO 740 L=0,JCAP UTOP(1,L+1,K)=-E(JE(N,L)+1)*Z(JC(N,L)-1,K) UTOP(2,L+1,K)=-E(JE(N,L)+1)*Z(JC(N,L) ,K) C VTOP(1,L+1,K)= E(JE(N,L)+1)*D(JC(N,L)-1,K) VTOP(2,L+1,K)= E(JE(N,L)+1)*D(JC(N,L) ,K) 740 CONTINUE C DO 820 J=1, 4032 U(J,K)=U(J,K)* 6.3712E+6 V(J,K)=V(J,K)* 6.3712E+6 820 CONTINUE C DO 840 J=1, 63 UTOP(1,J,K)=UTOP(1,J,K)* 6.3712E+6 UTOP(2,J,K)=UTOP(2,J,K)* 6.3712E+6 VTOP(1,J,K)=VTOP(1,J,K)* 6.3712E+6 VTOP(2,J,K)=VTOP(2,J,K)* 6.3712E+6 840 CONTINUE 10000 CONTINUE RETURN END SUBROUTINE DELLNP(Q,DPDPHS,DPDTOP,DPDLA) C PARAMETER (JCAP= 62 ) PARAMETER (LNEP=(JCAP+2)*(JCAP+3)/2) C C INPUT Q IS IN IBM TRIANG. ORDER C OUTPUT IS IN IBM TRIANG. ORDER C DIMENSION Q( 4033 ) DIMENSION DPDPHS( 4033 ) DIMENSION DPDTOP(2, 63 ) DIMENSION DPDLA( 4033 ) DIMENSION E(LNEP) C SAVE E, IFIRST C JE(N,L) =((JCAP+2)*(JCAP+3)-(JCAP+2-L)*(JCAP+3-L))/2+N-L C JC(N,L) = (JCAP+1)*(JCAP+2)-(JCAP+1-L)*(JCAP+2-L)+2*(N-L) C DATA IFIRST/1/ IF(IFIRST.NE.1)GO TO 280 C DO 220 L=0,JCAP N=L IE=JE(N,L)+1 E(IE)=0. 220 CONTINUE DO 260 L= 0,JCAP DO 240 N=L+1,JCAP+1 RN=N RL=L A=(RN*RN-RL*RL)/(4.*RN*RN-1.) IE=JE(N,L)+1 E(IE)=SQRT(A) 240 CONTINUE 260 CONTINUE IFIRST=0 280 CONTINUE C DO 340 L=0,JCAP RL=L DO 320 N=L,JCAP ICR=JC(N,L)+1 ICI=JC(N,L)+2 C DPDLA(L,N)= I*L*Q(L,N) C DPDLA(ICI)= RL*Q(ICR) DPDLA(ICR)=-RL*Q(ICI) 320 CONTINUE 340 CONTINUE C DO 440 L=0,JCAP-1 DO 420 N=L,JCAP-1 IE=JE(N+1,L)+1 ICR=JC(N,L)+1 ICI=JC(N,L)+2 RN=N DPDPHS(ICR)=(RN+2.)*E(IE)*Q(ICR+2) DPDPHS(ICI)=(RN+2.)*E(IE)*Q(ICI+2) 420 CONTINUE 440 CONTINUE C N= JCAP DO 540 L=0,JCAP ICR=JC(N,L)+1 ICI=JC(N,L)+2 DPDPHS(ICR)=0.0 DPDPHS(ICI)=0.0 540 CONTINUE C DO 640 L= 0,JCAP-1 DO 620 N=L+1,JCAP IE=JE(N,L)+1 ICR=JC(N,L)+1 ICI=JC(N,L)+2 RN=N DPDPHS(ICR)=DPDPHS(ICR)+(1.-RN)*E(IE)*Q(ICR-2) DPDPHS(ICI)=DPDPHS(ICI)+(1.-RN)*E(IE)*Q(ICI-2) 620 CONTINUE 640 CONTINUE C N=JCAP+1 RN=N DO 740 L=0,JCAP IE=JE(N,L)+1 ICR=JC(N,L)+1 ICI=JC(N,L)+2 DPDTOP(1,L+1)=(1.-RN)*E(IE)*Q(ICR-2) DPDTOP(2,L+1)=(1.-RN)*E(IE)*Q(ICI-2) 740 CONTINUE C AA=1./ 6.3712E+6 DO 820 J=1, 4032 DPDLA(J)= DPDLA(J)*AA DPDPHS(J)=DPDPHS(J)*AA 820 CONTINUE C DO 840 J=1, 63 DPDTOP(1,J)=DPDTOP(1,J)*AA DPDTOP(2,J)=DPDTOP(2,J)*AA 840 CONTINUE C RETURN END SUBROUTINE SWR95(S0,ISRC,PL,TA,WA,OA,CO2,COSZ,TAUCL, 1 CCLY,CFAC,ALBUVB,ALBUVD,ALBIRB,ALBIRD,PAER, 2 HTRC,TUPFXC,TDNFLX,SUPFXC,SDNFXC, 3 TUPFX0,SUPFX0,SDNFX0, 4 SDNFVB,SDNFVD,SDNFNB,SDNFND) CFPP$ NOCONCUR R C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SWR95 COMPUTES SHORT-WAVE RADIATIVE HEATING C PROGRAMMER: YU-TAI HOU ORG: W/NMC20 DATE: 95-02-09 C C ABSTRACT: THIS CODE IS A MODIFIED VERSION OF M.D. CHOU'S SW C RADIATION CODE TO FIT NMC MRF AND CLIMATE MODELS. IT COMPUTES C SW ATMOSPHERIC ABSORPTION AND SCATTERING EFFECTS DUE TO O3, C H2O,CO2,O2,CLOUDS, AND AEROSOLS, ETC. C IT HAS 4 UV+VIS BANDS AND 3 NIR BANDS (10 K-VALUES EACH). C C REFERENCES: CHOU (1986, J. CLIM. APPL.METEOR.) C CHOU (1990, J. CLIM.), AND CHOU (1992, J. ATMS. SCI.) C C PROGRAM HISTORY LOG: C 94-06-12 M.D. CHOU, GLA. C 95-02-09 YU-TAI HOU - RECODE FOR NMC MODELS C C USAGE: CALL SWR95 C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: CRAY C-90 C C INPUT PARAMETERS: C S0 : SOLAR CONSTANT C ISRC : FLAGS FOR SELECTING ABSORBERS C 1:AEROSOLS, 2:O2, 3:CO2, 4:H2O, 5:O3 C =0:WITHOUT IT, =1: WITH IT. C PL : MODEL LEVEL PRESSURE IN MB C TA : MODEL LAYER TEMPERATURE IN K C WA : LAYER SPECIFIC HUMIDITY IN GM/GM C OA : LAYER OZONE CONCENTRATION IN GM/GM C CO2 : CO2 MIXING RATION BY VOLUMN C COSZ : COSINE OF SOLAR ZENITH ANGLE C TAUCL : OPTICAL DEPTH OF CLOUD LAYERS C CCLY : LAYER CLOUD FRACTION C CFAC : FRACTION OF CLEAR SKY VIEW AT THE LAYER INTERFACE C ALBUVB : UV+VIS SURF DIRECT ALBEDO C ALBUVD : UV+VIS SURF DIFFUSED ALBEDO C ALBIRB : NIR SURF DIRECT ALBEDO C ALBIRD : NIR SURF DIFFUSED ALBEDO C PAER : AEROSOL PROFILES (FRACTION) C C OUTPUT PARAMETER: C HTRC : HEATING RATES FOR CLOUDY SKY IN K/DAY C TUPFXC : UPWARD FLUX AT TOA FOR CLOUDY SKY W/M**2 C TDNFLX : DNWARD FLUX AT TOA FOR ALL SKY W/M**2 C SUPFXC : UPWARD FLUX AT SFC FOR CLOUDY SKY W/M**2 C SDNFXC : DNWARD FLUX AT SFC FOR CLOUDY SKY W/M**2 C TUPFX0 : UPWARD FLUX AT TOA FOR CLEAR SKY W/M**2 C SUPFX0 : UPWARD FLUX AT SFC FOR CLEAR SKY W/M**2 C SDNFX0 : DNWARD FLUX AT SFC FOR CLEAR SKY W/M**2 C SDNFVB : DOWNWARD SURFACE VIS BEAM FLUX W/M**2 C SDNFNB : DOWNWARD SURFACE NIR BEAM FLUX W/M**2 C SDNFVD : DOWNWARD SURFACE VIS DIFF FLUX W/M**2 C SDNFND : DOWNWARD SURFACE NIR DIFF FLUX W/M**2 C C NOTE: C FOR ALL QUANTITIES, K=1 IS THE TOP LEVEL/LAYER, EXCEPT C SI AND SL, FOR WHICH K=1 IS THE SURFACE LEVEL/LAYER. C C$$$ C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C --- INPUT D I M E N S I O N 1 PL (IMBX,LP1), TA(IMBX,L), WA(IMBX,L), OA(IMBX,L) 2, TAUCL(IMBX,L), CCLY(IMBX,L), CFAC(IMBX,LP1),COSZ(IMAX) 3, ALBUVB(IMAX), ALBUVD(IMAX), ALBIRB(IMAX), ALBIRD(IMAX) 4, PAER(IMBX,6), ISRC(NSRC) C --- OUTPUT D I M E N S I O N 1 TUPFXC(IMAX), SUPFXC(IMAX), SDNFXC(IMAX), TDNFLX(IMAX) 2, TUPFX0(IMAX), SUPFX0(IMAX), SDNFX0(IMAX), HTRC(IMBX,L) 3, SDNFVB(IMAX), SDNFVD(IMAX), SDNFNB(IMAX), SDNFND(IMAX) C --- INTERNAL ARRAY D I M E N S I O N 1 FNET0(IMBX,LP1), FNETC(IMBX,LP1), HTR0 (IMBX,LP1) 2, DFLX0(IMBX,LP1), DFLXC(IMAX), DP (IMBX,L) 3, SCAL (IMBX,L), SWH (IMBX,LP1), SO2 (IMBX,LP1) 4, WH (IMBX,L), CSM (IMAX), CF0(IMAX), CF1(IMAX) 5, DWSFB0(IMAX), DWSFD0(IMAX), DWSFBC(IMAX), DWSFDC(IMAX) LOGICAL DAYTM(IMAX) DATA TAUCRT / 0.05 /, IFPR / 0 / C===> ... IBND=1:USE ONE NIR BAND, =2:USE THREE NIR BANDS DATA IBND / 1 / C===> ... BEGIN HERE IF (IFPR .EQ. 0) THEN WRITE(6,12) (ISRC(I),I=1,NSRC) 12 FORMAT(3X,'AEROSOL, O2, CO2, H2O, O3 =',5I3) IFPR = 1 END IF C NDAY = 0 DO 20 I=1,IMAX SWH (I,1) = 0.0 E 0 SO2 (I,1) = 0.0 E 0 TDNFLX(I) = S0 * COSZ(I) TUPFXC(I) = 0.0 E 0 TUPFX0(I) = 0.0 E 0 SUPFXC(I) = 0.0 E 0 SUPFX0(I) = 0.0 E 0 SDNFXC(I) = 0.0 E 0 SDNFX0(I) = 0.0 E 0 DFLXC(I) = 0.0 E 0 CF0(I) = CFAC(I,LP1) CF1(I) = 1.0 E 0 - CF0(I) C===> ... CSM IS THE EFFECTIVE SECANT OF THE SOLAR XENITH ANGLE CSM (I) = 35.0 E 0/(SQRT(1224.0 E 0*COSZ(I)*COSZ(I)+1.0 E 0)) DAYTM(I) = COSZ(I) .GT. 0.0 E 0 IF (DAYTM(I)) NDAY = NDAY + 1 20 CONTINUE C WRITE(6,22) NDAY C 22 FORMAT(2X,'IN SWR95: NDAY =',I4) IF (NDAY .EQ. 0) THEN DO 25 I=1,IMAX SDNFVB(I) = 0.0 E 0 SDNFVD(I) = 0.0 E 0 SDNFNB(I) = 0.0 E 0 SDNFND(I) = 0.0 E 0 25 CONTINUE DO 30 K=1,L DO 30 I=1,IMAX HTRC(I,K) = 0.0 E 0 30 CONTINUE RETURN END IF C DO 40 K=1,L DO 40 I=1,IMAX C===> ... LAYER THICKNESS AND PRESSURE SCALING FUNCTION FOR C WATER VAPOR ABSORPTION DP (I,K) = PL(I,K+1) - PL(I,K) SCAL(I,K) = DP(I,K) 1 * (0.5 E 0*(PL(I,K)+PL(I,K+1))/300.0 E 0)**0.8 E 0 C===> ... SCALED ABSORBER AMOUNTS FOR H2O(WH,SWH), UNIT IS G/CM**2 WH(I,K) = 1.02 E 0 * WA(I,K) * SCAL(I,K) C 1 * EXP(0.00135 E 0*(TA(I,K)-240.0 E 0)) 1 * (1.0 E 0 - 0.00135 E 0*(TA(I,K)-240.0 E 0)) SWH(I,K+1) = SWH(I,K) + WH(I,K) 40 CONTINUE C C===> ... INITIALIZE FLUXES C DO 80 K=1,LP1 DO 80 I=1,IMAX FNET0(I,K) = 0.0 E 0 FNETC(I,K) = 0.0 E 0 DFLX0(I,K) = 0.0 E 0 80 CONTINUE C C===> ... COMPUTE NIR FLUXES C IF (ISRC(4) .EQ. 1) THEN DO 100 I=1,IMAX DWSFB0(I) = 0.0 E 0 DWSFD0(I) = 0.0 E 0 DWSFBC(I) = 0.0 E 0 DWSFDC(I) = 0.0 E 0 100 CONTINUE C CALL SOLIR(WH,TAUCL,CSM,DAYTM,IBND, 1 ISRC(1),PAER,ALBIRB,ALBIRD, 2 TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, 3 FNET0,FNETC,DWSFB0,DWSFD0,DWSFBC,DWSFDC) C END IF C C===> ... SAVE SURFACE NIR BAND FLUXES C DO 110 I=1,IMAX SDNFNB(I) = CF0(I)*DWSFB0(I) + CF1(I)*DWSFBC(I) SDNFND(I) = CF0(I)*DWSFD0(I) + CF1(I)*DWSFDC(I) 110 CONTINUE C C===> ... COMPUTE UV+VISIBLE FLUXES C SCALED AMOUNTS FOR O3(WH), UNIT IS (CM-AMT)STP FOR O3. IF (ISRC(5) .EQ. 1) THEN XA = 1.02 E 0 * 466.7 E 0 DO 120 K=1,L DO 120 I=1,IMAX WH(I,K) = XA * OA(I,K) * DP(I,K) 120 CONTINUE C DO 125 I=1,IMAX DWSFB0(I) = 0.0 E 0 DWSFD0(I) = 0.0 E 0 DWSFBC(I) = 0.0 E 0 DWSFDC(I) = 0.0 E 0 125 CONTINUE C CALL SOLUV(WH,TAUCL,CSM,DAYTM, 1 ISRC(1),PAER,ALBUVB,ALBUVD, 2 TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, 3 FNET0,FNETC,DWSFB0,DWSFD0,DWSFBC,DWSFDC) C END IF C DO 130 I=1,IMAX C===> ... SAVE SURFACE DOWNWARD VIS BAND FLUXES SDNFVB(I) = CF0(I)*DWSFB0(I) + CF1(I)*DWSFBC(I) SDNFVD(I) = CF0(I)*DWSFD0(I) + CF1(I)*DWSFDC(I) C===> ... COMPUTE FINAL FLUXES TUPFXC(I) = CF0(I)*TUPFX0(I) + CF1(I)*TUPFXC(I) SUPFXC(I) = CF0(I)*SUPFX0(I) + CF1(I)*SUPFXC(I) SDNFXC(I) = CF0(I)*SDNFX0(I) + CF1(I)*SDNFXC(I) 130 CONTINUE DO 140 K=1,LP1 DO 140 I=1,IMAX FNETC (I,K) = CF0(I)*FNET0(I,K) + CF1(I)*FNETC(I,K) 140 CONTINUE C C===> ... COMPUTE THE ABSORPTION DUE TO OXYGEN,CHOU(1990,J.CLIMATE,209-2 C SCALED AMOUNTS FOR O2(O2,SO2), UNIT IS (CM-ATM)STP FOR O2. IF (ISRC(2) .EQ. 1) THEN DO 150 K=1,L DO 150 I=1,IMAX SO2(I,K+1) = SO2(I,K) + 165.22 E 0 * SCAL(I,K) 150 CONTINUE C===> ... TO2 IS THE BROADBAND TRANSMISSION FUNCTION FOR OXYGEN C 0.0287 IS THE FRACTION OF SOLAR FLUX IN THE O2 BANDS DO 160 K=2,LP1 DO 160 I=1,IMAX TO2 = EXP(-0.00027 E 0 * SQRT(SO2(I,K) * CSM(I))) DFLX0(I,K) = 0.0287 E 0 * (1.0 E 0 - TO2) 160 CONTINUE END IF C C===> ... TABLE LOOK-UP FOR THE ABSORPTION DUE TO CO2 C COMPUTE SCALED AMOUNTS FOR CO2(WC,SO2). IF (ISRC(3) .EQ. 1) THEN XA = CO2 * 789. E 0 DO 170 K=1,L DO 170 I=1,IMAX SO2(I,K+1) = SO2(I,K) + XA*SCAL(I,K) 170 CONTINUE C CALL FLXCO2(SO2,SWH,CSM,DAYTM,DFLX0) C END IF C C===> ... ADJUST FOR THE EFFECT OF O2 AND CO2 ON CLEAR SKY NET FLUXE C IF (ISRC(2).EQ.1 .OR. ISRC(3).EQ.1) THEN CLEAR DO 180 K=1,LP1 C DO 180 I=1,IMAX C FNET0(I,K) = FNET0(I,K) - DFLX0(I,K) C180 CONTINUE C C===> ... ADJUST FOR THE EFFECT OF O2 AND CO2 ON CLOUD SKY NET FLUXE C DO 190 K=1,L DO 190 I=1,IMAX IF (CCLY(I,K) .GT. 0.01 E 0) 1 DFLXC(I) = DFLXC(I) + DFLX0(I,K)*CFAC(I,K)*CCLY(I,K) FNETC(I,K+1) = FNETC(I,K+1) - DFLXC(I) 1 - DFLX0(I,K+1)*CFAC(I,K+1) 190 CONTINUE C C===> ... ADJUST FOR OTHER FLUXES C DO 200 I=1,IMAX XX = DFLXC(I) + CF0(I)*DFLX0(I,LP1) SDNFX0(I) = SDNFX0(I) - DFLX0(I,LP1) SDNFXC(I) = SDNFXC(I) - XX SDNFNB(I) = SDNFNB(I) - XX 200 CONTINUE END IF C C===> ... CONVERT FLUX UNIT TO W/M**2 C DO 210 K=1,LP1 DO 210 I=1,IMAX CLEAR FNET0 (I,K) = FNET0(I,K) * TDNFLX(I) FNETC (I,K) = FNETC(I,K) * TDNFLX(I) 210 CONTINUE DO 220 I=1,IMAX SDNFNB(I) = SDNFNB(I) * TDNFLX(I) SDNFND(I) = SDNFND(I) * TDNFLX(I) SDNFVB(I) = SDNFVB(I) * TDNFLX(I) SDNFVD(I) = SDNFVD(I) * TDNFLX(I) TUPFX0(I) = TUPFX0(I) * TDNFLX(I) TUPFXC(I) = TUPFXC(I) * TDNFLX(I) SUPFX0(I) = SUPFX0(I) * TDNFLX(I) SUPFXC(I) = SUPFXC(I) * TDNFLX(I) SDNFX0(I) = SDNFX0(I) * TDNFLX(I) SDNFXC(I) = SDNFXC(I) * TDNFLX(I) 220 CONTINUE C C===> ... FAC IS THE FACTOR FOR HEATING RATES (IN K/DAY) C IF USE K/SEC, RESULT SHOULD BE DEVIDED BY 86400. C C FAC = 3.6*24./10.03*.98 FAC = 8.4418744 E 0 C DO 230 K=1,L DO 230 I=1,IMAX CLEAR HTR0(I,K) = (FNET0(I,K)-FNET0(I,K+1)) * FAC / DP(I,K) HTRC(I,K) = (FNETC(I,K)-FNETC(I,K+1)) * FAC / DP(I,K) 230 CONTINUE C RETURN END SUBROUTINE SOLUV(OZ,TAUCL,CSM,DAYTM, 1 KAER,PAER,ALBB,ALBD, 2 TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, 3 FNET0,FNETC,DWSFB0,DWSFD0,DWSFBC,DWSFDC) CFPP$ NOCONCUR R C******************************************************************* C COMPUTE SOLAR FLUX IN THE UV+VISIBLE REGION C THE UV+VISIBLE REGION IS GROUPED INTO 4 BANDS: C (.225-.285);(.175-.225,.285-.300);(.300-.325);(.325-.690) C C INPUT PARAMETERS: UNITS C OZ,TAUCL,CSM,DAYTM,KAER,PAER,ALBB,ALBD C C OUTPUT PARAMETERS: C FNET0 : CLEAR SKY NET FLUX C FNETC : CLOUDY SKY NET FLUX C TUPFXC : CLOUDY SKY UPWARD FLUX AT TOA C SUPFXC : CLOUDY SKY UPWARD FLUX AT SFC C SDNFXC : CLOUDY SKY DOWNWARD FLUX AT SFC C TUPFX0 : CLEAR SKY UPWARD FLUX AT TOA C SUPFX0 : CLEAR SKY UPWARD FLUX AT SFC C SDNFX0 : CLEAR SKY DOWNWARD FLUX AT SFC C DWSFB0 : CLEAR SKY SFC DOWN DIR. FLUX C DWSFD0 : CLEAR SKY SFC DOWN DIF. FLUX C DWSFBC : CLOUDY SKY SFC DOWN DIR. FLUX C DWSFDC : CLOUDY SKY SFC DOWN DIF. FLUX C C FIXED INPUT DATA: C FRACTION OF SOLAR FLUX CONTAINED C IN THE 8 BANDS (SS) FRACTION C RAYLEIGH OPTICAL THICKNESS (TAURAY) /MB C OZONE ABSORPTION COEFFICIENT (AK) /(CM-ATM)STP C C THE FOLLOWING PARAMETERS MUST BE SPECIFIED BY USERS: C CLOUD ASYMMETRY FACTOR (ASYCL) N/D C AEROSOL PARAMETERS ARE FROM SUBPROGRAM AEROS: C******************************************************************** C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C --- INPUT D I M E N S I O N 1 OZ(IMBX,L), TAUCL(IMBX,L), ALBB(IMAX), ALBD(IMAX) 2, CSM(IMAX), PAER(IMBX,NAE) LOGICAL DAYTM(IMAX) C --- OUTPUT D I M E N S I O N 1 FNET0 (IMBX,LP1), DWSFB0(IMAX), DWSFD0(IMAX) 2, FNETC (IMBX,LP1), DWSFBC(IMAX), DWSFDC(IMAX) 3, TUPFXC(IMAX), SUPFXC(IMAX), SDNFXC(IMAX) 4, TUPFX0(IMAX), SUPFX0(IMAX), SDNFX0(IMAX) C --- TEMPORARY ARRAY D I M E N S I O N 1 UPFLUX(IMBX,LP1), DWFLUX(IMBX,LP1) C 2, DWSFXB(IMAX), DWSFXD(IMAX), TAURS (L) 2, DWSFXB(IMAX), DWSFXD(IMAX) 3, TAUTO (IMBX,L), SSATO (IMBX,L), ASYTO (IMBX,L) 4, TAURS (L), SSAT1 (IMBX,L), ASYT1 (IMBX,L) C 4, TAUT1 (IMBX,L), SSAT1 (IMBX,L), ASYT1 (IMBX,L) 5, TAUAER(IMBX,L), SSAAER(IMBX,L), ASYAER(IMBX,L) 6, R0 (IMBX,LP1), T0 (IMBX,LP1), TB (IMBX,LP1) 7, RF (IMBX,LP1), TF (IMBX,LP1) C --- SOLAR FLUX AND ABSORPTION COEFFICIENTS 6, SS(NVB), AK(NVB) C DATA SS / 0.00530, 0.00505, 0.01109, 0.44498 / DATA AK / 0.1805E+3, 0.267E+2, 0.199E+1, 0.050 / DATA ASYCL / 0.843 / DATA FPMIN, FPMAX / 1.0E-8, 0.9999999 / C C===> ... INTEGRATION OVER SPECTRAL BANDS C DO 100 IV=1,NVB C C===> ... GET AEROSOLS AND RAYLEIGH SCATTERING OPTICAL PROPERTIES C CALL AEROS(IV,KAER,PAER,TAUAER,SSAAER,ASYAER,TAURS) C C===> ... COMPUTE TOTAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, C AND ASYMMETRY FACTOR FOR CLEAR SKY C DO 30 K=1,L DO 30 I=1,IMAX C TAUT1(I,K) = AK(IV)*OZ(I,K) + TAUAER(I,K) + TAURS(K) TAUTO(I,K) = AMAX1(FPMIN, 1 AK(IV)*OZ(I,K)+TAUAER(I,K)+TAURS(K)) SSAT1(I,K) = SSAAER(I,K)*TAUAER(I,K) + TAURS(K) ASYT1(I,K) = ASYAER(I,K)*SSAAER(I,K)*TAUAER(I,K) C TAUTO(I,K) = AMAX1(FPMIN, TAUT1(I,K)) SSATO(I,K) = AMIN1(FPMAX, SSAT1(I,K)/TAUTO(I,K)) ASYTO(I,K) = ASYT1(I,K) / AMAX1(FPMIN, SSAT1(I,K)) 30 CONTINUE C C===> ... CLEAR SKY FLUXES CALCULATIONS C CALL SWFLUX(TAUTO,SSATO,ASYTO,CSM,ALBB,ALBD,DAYTM, 1 1,UPFLUX,DWFLUX,DWSFXB,DWSFXD) C DO 40 K=1,LP1 DO 40 I=1,IMAX FNET0(I,K) = FNET0(I,K) 1 + (DWFLUX(I,K) - UPFLUX(I,K))*SS(IV) 40 CONTINUE DO 50 I=1,IMAX TUPFX0(I) = TUPFX0(I) + UPFLUX(I,1) *SS(IV) SUPFX0(I) = SUPFX0(I) + UPFLUX(I,LP1)*SS(IV) SDNFX0(I) = SDNFX0(I) + DWFLUX(I,LP1)*SS(IV) DWSFB0(I) = DWSFB0(I) + DWSFXB(I)*SS(IV) DWSFD0(I) = DWSFD0(I) + DWSFXD(I)*SS(IV) 50 CONTINUE C C===> ... COMPUTE TOTAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, C AND ASYMMETRY FACTOR FOR CLOUDY SKY C DO 60 K=1,L DO 60 I=1,IMAX IF (TAUCL(I,K) .GT. 0.0 E 0) THEN C TAUTO(I,K) = TAUCL(I,K) + TAUT1(I,K) TAUTO(I,K) = TAUCL(I,K) + TAUTO(I,K) SSAT1(I,K) = TAUCL(I,K) + SSAT1(I,K) SSATO(I,K) = AMIN1(FPMAX, SSAT1(I,K)/TAUTO(I,K)) ASYTO(I,K) = (ASYCL*TAUCL(I,K)+ASYT1(I,K)) 1 / SSAT1(I,K) END IF 60 CONTINUE C C===> ... CLOUDY SKY FLUXES CALCULATIONS C CALL SWFLUX(TAUTO,SSATO,ASYTO,CSM,ALBB,ALBD,DAYTM, 1 1,UPFLUX,DWFLUX,DWSFXB,DWSFXD) C DO 70 K=1,LP1 DO 70 I=1,IMAX FNETC(I,K) = FNETC(I,K) 1 + (DWFLUX(I,K) - UPFLUX(I,K))*SS(IV) 70 CONTINUE DO 80 I=1,IMAX TUPFXC(I) = TUPFXC(I) + UPFLUX(I,1) *SS(IV) SUPFXC(I) = SUPFXC(I) + UPFLUX(I,LP1)*SS(IV) SDNFXC(I) = SDNFXC(I) + DWFLUX(I,LP1)*SS(IV) DWSFBC(I) = DWSFBC(I) + DWSFXB(I)*SS(IV) DWSFDC(I) = DWSFDC(I) + DWSFXD(I)*SS(IV) 80 CONTINUE C 100 CONTINUE C RETURN END SUBROUTINE SOLIR(WH,TAUCL,CSM,DAYTM,IBND, 1 KAER,PAER,ALBB,ALBD, 2 TUPFXC,SUPFXC,SDNFXC,TUPFX0,SUPFX0,SDNFX0, 3 FNET0,FNETC,DWSFB0,DWSFD0,DWSFBC,DWSFDC) CFPP$ NOCONCUR R C******************************************************************** C COMPUTE SOLAR FLUX IN THE NIR REGION (3 BANDS, 10-K PER BAND) C THE NIR REGION HAS THREE WATER VAPOR BANDS, TEN K's FOR EACH BAND. C 1. 1000-4400 (/cm) 2.27-10.0 (micron) C 2. 4400-8200 1.22-2.27 C 3. 8200-14300 0.70-1.22 C C INPUT PARAMETERS: UNITS C WH,TAUCL,CSM,DAYTM,IBND,KAER,PAER,ALBB,ALBD C FIXED INPUT DATA: C H2O ABSORPTION COEFFICIENT (XK) CM**2/GM C K-DISTRIBUTION FUNCTION (HK) FRACTION C C THE FOLLOWING PARAMETERS MUST SPECIFIED BY USERS: C CLOUD SINGLE SCATTERING ALBEDO (SACL) N/D C CLOUD ASYMMETRY FACTOR (ASYCL) N/D C AEROSOLS OPTICAL PARAMETERS ARE OBTAINED FROM CALLING C SUBPROGRAM AEROS C C OUTPUT PARAMETERS: C FNET0 : CLEAR SKY NET FLUX C FNETC : CLOUDY SKY NET FLUX C TUPFXC : CLOUDY SKY UPWARD FLUX AT TOA C SUPFXC : CLOUDY SKY UPWARD FLUX AT SFC C SDNFXC : CLOUDY SKY DOWNWARD FLUX AT SFC C TUPFX0 : CLEAR SKY UPWARD FLUX AT TOA C SUPFX0 : CLEAR SKY UPWARD FLUX AT SFC C SDNFX0 : CLEAR SKY DOWNWARD FLUX AT SFC C DWSFB0 : CLEAR SKY SFC DOWN DIR. FLUX C DWSFD0 : CLEAR SKY SFC DOWN DIF. FLUX C DWSFBC : CLOUDY SKY SFC DOWN DIR. FLUX C DWSFDC : CLOUDY SKY SFC DOWN DIF. FLUX C******************************************************************** C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C --- INPUT D I M E N S I O N 1 WH(IMBX,L), TAUCL(IMBX,L), CSM(IMAX), PAER(IMBX,NAE) 2, ALBB(IMAX), ALBD(IMAX) LOGICAL DAYTM(IMAX) C --- OUTPUT D I M E N S I O N 1 FNET0 (IMBX,LP1), DWSFB0(IMAX), DWSFD0(IMAX) 2, FNETC (IMBX,LP1), DWSFBC(IMAX), DWSFDC(IMAX) 3, TUPFXC(IMAX), SUPFXC(IMAX), SDNFXC(IMAX) 4, TUPFX0(IMAX), SUPFX0(IMAX), SDNFX0(IMAX) C --- TEMPORARY ARRAY D I M E N S I O N 1 UPFLUX(IMBX,LP1), DWFLUX(IMBX,LP1) C 2, DWSFXB(IMAX), DWSFXD(IMAX), TAURS (L) 2, DWSFXB(IMAX), DWSFXD(IMAX) 3, TAUTO (IMBX,L), SSATO (IMBX,L), ASYTO (IMBX,L) 4, TAURS (L), SSAT1 (IMBX,L), ASYT1 (IMBX,L) C 4, TAUT1 (IMBX,L), SSAT1 (IMBX,L), ASYT1 (IMBX,L) 5, TAUAER(IMBX,L), SSAAER(IMBX,L), ASYAER(IMBX,L) 6, R0 (IMBX,LP1), T0 (IMBX,LP1), TB (IMBX,LP1) 7, RF (IMBX,LP1), TF (IMBX,LP1) 8, XK (NK0), HK (NK0,NRB), SACL(NRB) C DATA XK / 0.0010, 0.0133, 0.0422, 0.1334, 0.4217, 1 1.3340, 5.6230, 31.620, 177.80, 1000.0 / DATA HK / .01074, .00360, .00411, .00421, .00389, 1 .00326, .00499, .00465, .00245, .00145, 2 .08236, .01157, .01133, .01143, .01240, 2 .01258, .01381, .00650, .00244, .00094, 3 .20673, .03497, .03011, .02260, .01336, 3 .00696, .00441, .00115, .00026, .00000, 4 .29983, .05014, .04555, .03824, .02965, 4 .02280, .02321, .01230, .00515, .00239 / C DATA SACL / 0.98, 0.994, 0.9995, 0.99 /, ASYCL / 0.843 / DATA FPMIN,FPMAX /1.0E-6, 0.999999/ C DATA SSAWV/0.00001/ C C===> ... LOOP OVER THREE NIR BANDS C IF (IBND .EQ. 1) THEN IBB1 = NRB IBB2 = NRB ELSE IBB1 = 1 IBB2 = NRB - 1 END IF DO 200 IB=IBB1,IBB2 C C===> ... GET AEROSOLS AND RAYLEIGH SCATTERING OPTICAL PROPERTIES C IB1 = NVB + IB CALL AEROS(IB1,KAER,PAER,TAUAER,SSAAER,ASYAER,TAURS) C SSACL=SACL(IB) C C===> ... IK IS THE INDEX FOR THE K-DISTRIBUTION FUNCTION (OR THE C ABSORPTION COEFFICIENT) C DO 100 IK=1,NK0 C IF (HK(IK,IB) .LT. 0.00001) GO TO 100 C C===> ... COMPUTE TATAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, C AND ASYMMETRY FACTOR FOR CLEAR SKY C DO 30 K=1,L DO 30 I=1,IMAX TAUWV = XK(IK)*WH(I,K) C TAUT1(I,K) = TAUWV + TAUAER(I,K) + TAURS(K) TAUTO(I,K) = AMAX1(FPMIN, 1 TAUWV+TAUAER(I,K)+TAURS(K)) C SSAT1(I,K) = SSAWV*TAUWV+SSAAER(I,K)*TAUAER(I,K)+TAURS(K) SSAT1(I,K) = SSAAER(I,K)*TAUAER(I,K)+TAURS(K) ASYT1(I,K) = ASYAER(I,K)*SSAAER(I,K)*TAUAER(I,K) C TAUTO(I,K) = AMAX1(FPMIN, TAUT1(I,K)) SSATO(I,K) = AMIN1(FPMAX, SSAT1(I,K)/TAUTO(I,K)) ASYTO(I,K) = ASYT1(I,K) / AMAX1(FPMIN, SSAT1(I,K)) 30 CONTINUE C C===> ... CLEAR SKY FLUXES CALCULATIONS C CALL SWFLUX(TAUTO,SSATO,ASYTO,CSM,ALBB,ALBD,DAYTM, 1 2,UPFLUX,DWFLUX,DWSFXB,DWSFXD) C DO 40 K=1,LP1 DO 40 I=1,IMAX FNET0 (I,K) = FNET0 (I,K) 1 + (DWFLUX(I,K) - UPFLUX(I,K))*HK(IK,IB) 40 CONTINUE DO 50 I=1,IMAX TUPFX0(I) = TUPFX0(I) + UPFLUX(I,1) *HK(IK,IB) SUPFX0(I) = SUPFX0(I) + UPFLUX(I,LP1)*HK(IK,IB) SDNFX0(I) = SDNFX0(I) + DWFLUX(I,LP1)*HK(IK,IB) DWSFB0(I) = DWSFB0(I) + DWSFXB(I)*HK(IK,IB) DWSFD0(I) = DWSFD0(I) + DWSFXD(I)*HK(IK,IB) 50 CONTINUE C C===> ... COMPUTE TATAL OPTICAL THICKNESS, SINGLE SCATTERING ALBEDO, C AND ASYMMETRY FACTOR FOR CLOUDY SKY C DO 60 K=1,L DO 60 I=1,IMAX IF (TAUCL(I,K) .GE. 0.001 E 0) THEN C TAUTO(I,K) = TAUCL(I,K) + TAUT1(I,K) TAUTO(I,K) = TAUCL(I,K) + TAUTO(I,K) SSAT1(I,K) = SSACL*TAUCL(I,K) + SSAT1(I,K) SSATO(I,K) = AMIN1(FPMAX, SSAT1(I,K)/TAUTO(I,K)) ASYTO(I,K) = (ASYCL*SSACL*TAUCL(I,K) + ASYT1(I,K)) 1 / SSAT1(I,K) END IF 60 CONTINUE C C===> ... CLOUDY SKY FLUXES CALCULATIONS C CALL SWFLUX(TAUTO,SSATO,ASYTO,CSM,ALBB,ALBD,DAYTM, 1 2,UPFLUX,DWFLUX,DWSFXB,DWSFXD) C DO 70 K=1,LP1 DO 70 I=1,IMAX FNETC(I,K) = FNETC(I,K) 1 + (DWFLUX(I,K) - UPFLUX(I,K))*HK(IK,IB) 70 CONTINUE DO 80 I=1,IMAX TUPFXC(I) = TUPFXC(I) + UPFLUX(I,1) *HK(IK,IB) SUPFXC(I) = SUPFXC(I) + UPFLUX(I,LP1)*HK(IK,IB) SDNFXC(I) = SDNFXC(I) + DWFLUX(I,LP1)*HK(IK,IB) DWSFBC(I) = DWSFBC(I) + DWSFXB(I)*HK(IK,IB) DWSFDC(I) = DWSFDC(I) + DWSFXD(I)*HK(IK,IB) 80 CONTINUE C 100 CONTINUE 200 CONTINUE C RETURN END SUBROUTINE SWFLUX(TAU,SSC,G0,CSM,ALB,ALD,DAYTM, 1 ISBD,UPFLUX,DWFLUX,DWSFCB,DWSFCD) CFPP$ NOCONCUR R C******************************************************************** C USES THE DELTA-EDDINGTON APPROXIMATION TO COMPUTE THE BULK C SCATTERING PROPERTIES OF A SINGLE LAYER CODED FOLLOWING C COAKLEY ET AL. (JAS, 1982) C C INPUTS: C TAU: THE EFFECTIVE OPTICAL THICKNESS C SSC: THE EFFECTIVE SINGLE SCATTERING ALBEDO C G0: THE EFFECTIVE ASYMMETRY FACTOR C CSM: THE EFFECTIVE SECANT OF THE ZENITH ANGLE C ALB: SURFACE ALBEDO FOR DIRECT RADIATION C ALD: SURFACE ALBEDO FOR DIFFUSED RADIATION C DAYTM: DAYTIME FLAG C ISBD: =1 FOR UV+VIS SPECTRAL BANDS C =2 FOR NIR SPECTRAL BANDS C C OUTPUTS: C UPFLUX: UPWARD FLUXES C DWFLUX: DOWNWARD FLUXES C DWSFCB: DOWNWARD SURFACE FLUX DIRECT COMPONENT C DWSFCD: DOWNWARD SURFACE FLUX DIFFUSED COMPONENT C******************************************************************** C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C --- INPUT D I M E N S I O N 1 TAU(IMBX,L), SSC(IMBX,L), G0(IMBX,L) 2, CSM(IMAX), ALB(IMAX), ALD(IMAX) LOGICAL DAYTM(IMAX) C --- OUTPUT D I M E N S I O N 1 UPFLUX(IMBX,LP1),DWFLUX(IMBX,LP1),DWSFCB(IMAX),DWSFCD(IMAX) C --- TEMPORARY D I M E N S I O N 1 TB (IMBX,LP1),R0 (IMBX,LP1),T0 (IMBX,LP1), RF (IMBX,LP1) 2, TTB(IMBX,LP1),TDN(IMBX,LP1),RUP(IMBX,LP1), TF (IMBX,LP1) 3, TFD(IMBX,LP1),RFU(IMBX,LP1),RFD(IMBX,LP1), ZTH(IMAX) C DO 10 I=1,IMAX TB(I,LP1) = 0.0 E 0 R0(I,LP1) = ALB(I) T0(I,LP1) = 0.0 E 0 RF(I,LP1) = ALD(I) TF(I,LP1) = 0.0 E 0 ZTH(I) = 1.0 E 0 / CSM(I) 10 CONTINUE C DO 20 K=1,L DO 20 I=1,IMAX IF (DAYTM(I)) THEN C===> ... DELTA-EDDINGTON SCALING OF SINGLE SCATTERING ALBEDO, C OPTICAL THICKNESS, AND ASYMMETRY FACTOR, K & H EQS(27-29) FF = G0(I,K) * G0(I,K) AA = 1.0 E 0 - FF*SSC(I,K) TAUP = TAU(I,K) * AA SSCP = SSC(I,K) * (1.0 E 0 - FF) / AA GP = G0(I,K) / (1.0 E 0 + G0(I,K)) C OMS1 = 1.0 E 0 - SSCP OGS1 = 1.0 E 0 - SSCP*GP TLAM = 3.0 E 0 * OMS1*OGS1 SLAM = SQRT(TLAM) ZZ = ZTH(I) * ZTH(I) DEN1 = 1.0 E 0 - TLAM*ZZ C===> ... SAFETY CHECK DEN = SSCP / SIGN(AMAX1(1.0 E -20, ABS(DEN1)), DEN1) C GAMA = 0.50 E 0 * (1.0 E 0 + 3.0 E 0*GP*OMS1*ZZ) * DEN ALFA = 0.75 E 0 * ZTH(I) * (GP + OGS1) * DEN U1 = 1.50 E 0 * OGS1 / SLAM UP1 = U1 + 1.0 E 0 UM1 = U1 - 1.0 E 0 AMG = ALFA - GAMA APG = ALFA + GAMA C C===> ... COMPUTE LAYER TRANSMISSIONS AND REFLECTIONS C R0 : LAYER REFLECTION OF THE DIRECT BEAM C T0 : LAYER DIFFUSE+DIRECT TRANSMISSION OF DIRECT BEAM C RF : LAYER REFLECTION OF THE DIFFUSED RADIATION C TF : LAYER TRANSMISSION OF THE DIFFUSED RADIATION C TB : LAYER DIREC TRANSMISSION OF THE DIRECT BEAM C E1 = EXP( -TAUP*SLAM ) UE = U1 * E1 UEPE= UE + E1 UEME= UE - E1 DEN = 1.0 E 0 / ((UP1 + UEME)*(UP1 - UEME)) C ARG = AMIN1(30.0 E 0, TAUP*CSM(I)) TB1 = EXP(-ARG) RF1 = (UP1 + UEPE) * (UM1 - UEME) * DEN TF1 = 4.0 E 0 * UE * DEN ZA = AMG * TB1 R01 = ZA * TF1 + APG * RF1 - AMG T01 = ZA * RF1 + APG * TF1 - (APG - 1.0 E 0)*TB1 C TB(I,K) = AMAX1(0.0 E 0, TB1) R0(I,K) = AMAX1(0.0 E 0, R01) T0(I,K) = AMAX1(0.0 E 0, T01) RF(I,K) = AMAX1(0.0 E 0, RF1) TF(I,K) = AMAX1(0.0 E 0, TF1) ELSE TB(I,K) = 0.0 E 0 R0(I,K) = 0.0 E 0 T0(I,K) = 0.0 E 0 RF(I,K) = 0.0 E 0 TF(I,K) = 0.0 E 0 END IF 20 CONTINUE C IF (ISBD .EQ. 2) THEN DO 40 K=1,L DO 40 I=1,IMAX IF (DAYTM(I).AND.SSC(I,K).LE.0.0001 E 0) THEN TB(I,K) = EXP(-TAU(I,K)*CSM(I)) T0(I,K) = TB(I,K) R0(I,K) = 0.0 E 0 TF(I,K) = EXP(-1.66 E 0*TAU(I,K)) RF(I,K) = 0.0 E 0 END IF 40 CONTINUE END IF C DO 60 I=1,IMAX TDN(I,1) = T0(I,1) RFD(I,1) = RF(I,1) TFD(I,1) = TF(I,1) TTB(I,1) = TB(I,1) TTB(I,L) = 0.0 E 0 60 CONTINUE C C===> ... LAYERS ADDED DOWNWARD STARTING FROM TOP C DO 80 K=2,LP1 DO 80 I=1,IMAX IF (DAYTM(I)) THEN DEN = TF(I,K) / (1.0 E 0 - RFD(I,K-1) * RF(I,K)) TDN(I,K) = TTB(I,K-1)*T0(I,K) + (TDN(I,K-1)-TTB(I,K-1) 1 + TTB(I,K-1)*R0(I,K)*RFD(I,K-1)) * DEN RFD(I,K) = RF(I,K) + TF(I,K)*RFD(I,K-1) * DEN TFD(I,K) = TFD(I,K-1) * DEN TTB(I,K) = TTB(I,K-1) * TB(I,K) END IF 80 CONTINUE C C===> ... LAYERS ADDED UPWARD STARTING FROM SURFACE C DO 100 I=1,IMAX RFU(I,LP1) = RF(I,LP1) RUP(I,LP1) = R0(I,LP1) 100 CONTINUE DO 120 K=L,1,-1 DO 120 I=1,IMAX IF (DAYTM(I)) THEN DEN = TF(I,K) / (1.0 E 0 - RFU(I,K+1) * RF(I,K)) RUP(I,K) = R0(I,K) + ((T0(I,K)-TB(I,K))*RFU(I,K+1) 1 + TB(I,K)*RUP(I,K+1)) * DEN RFU(I,K) = RF(I,K) + TF(I,K)*RFU(I,K+1) * DEN END IF 120 CONTINUE C C===> ... FIND UPWARD AND DOWNWARD FLUXES C DO 160 I=1,IMAX IF (DAYTM(I)) THEN UPFLUX(I,1) = RUP(I,1) DWFLUX(I,1) = 1.0 E 0 ELSE UPFLUX(I,1) = 0.0 E 0 DWFLUX(I,1) = 0.0 E 0 END IF 160 CONTINUE DO 180 K=2,LP1 DO 180 I=1,IMAX IF (DAYTM(I)) THEN DEN = 1.0 E 0 / (1.0 E 0 - RFD(I,K-1)*RFU(I,K)) UPFLUX(I,K) = (TTB(I,K-1)*RUP(I,K) + 1 (TDN(I,K-1)-TTB(I,K-1))*RFU(I,K)) * DEN DWFLUX(I,K) = TTB(I,K-1) + ((TDN(I,K-1)-TTB(I,K-1)) 1 + TTB(I,K-1)*RUP(I,K)*RFD(I,K-1)) * DEN ELSE UPFLUX(I,K) = 0.0 E 0 DWFLUX(I,K) = 0.0 E 0 END IF 180 CONTINUE C C===> ... SURFACE DOWNWARD FLUXES C DO 200 I=1,IMAX DWSFCB(I) = TTB(I,L) DWSFCD(I) = DWFLUX(I,LP1)-DWSFCB(I) 200 CONTINUE C RETURN END SUBROUTINE AEROS(IB,KAER,PAER,TAU,SSA,ASY,TAURS) CFPP$ NOCONCUR R C******************************************************************** C COMPUTE AEROSOLS OPTICAL PROPERTIES OF SIX TYPICAL PROFILES C IN FOUR UV+VIS BANDS AND FOUR NIR BANDS. C BAND: 1. 0.225-0.285 (UV) 2. 0.175-0.225;0.285-0.300 (UV) C 3. 0.300-0.325 (UV) 4. 0.325-0.690 (PAR) C 5. 2.27 - 4.0 (NIR) 6. 1.22 - 2.27 (NIR) C 7. 0.70 - 1.22 (NIR) 8. 0.70 - 4.0 (NIR) C REF: WMO REPORT WCP-112 (1986) C C FORMULATIONS: C DTAU(K) = ZK(K) * DZ(K) C ZK(K) = ZK(0) * (PRSS(K)/PRESS(0))**(H/HD) FOR EXP TYPE C = CONST FOR OTHERS C Z(K) = -HH * (LN(PRESS(K))-LN(PRESS(K+1))) C HH - ATMOSPHERIC SCALE HEIGHT, A FUCTION OF PRESS C HD - AEROSOLS SCALE HEIGHT C WHERE ZK IS EXT. COEFF.; Z IS HEIGHT; THE VERTICAL INDECES ARE C K=1 AT SURFACE FOR INPUT SIGMA LEVELS AND K=1 AT TOP FOR ALL C OTHER QUANTITIES. C C INPUT PARAMETERS: C IB,KAER,PAER C C OUTPUT PARAMETERS: C TAU - OPTICAL DEPTH N/D C SSA - SINGLE SCATTERING ALBEDO N/D C ASY - ASYMMETRY PARAMETER N/D C TAURS- RAYLEIGH SCATTERING OPTICAL DEPTH N/D C******************************************************************** C PARAMETER ( NDM=6 ) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) C --- INPUT DIMENSION PAER(IMBX,NAE) C --- OUTPUT D I M E N S I O N 1 TAU(IMBX,L), SSA(IMBX,L), ASY(IMBX,L), TAURS(L) LOGICAL LAER C --- VARIABLES IN COMMON BLOCK D I M E N S I O N 1 SIG0(L,NAE), IDM (L,NAE), DZ (L), HH (L) 3, OAER(NDM,NAE,NBD), GAER(NDM,NAE,NBD), RAER(NBD) 4, HAER(NDM,NAE), ZAER(NDM,NAE), TAUR(L,NBD) C O M M O N /SWAER/ 1 SIG0,HAER,ZAER,HH,DZ,IDM,OAER,GAER,RAER,TAUR DATA CRT1,CRT2 / 30.0, 0.03333 / C C===> ... LAYER OPTICAL DEPTH DUE TO RAYLEIGH SCATTERING C DO 20 K=1,L TAURS(K) = TAUR(K,IB) 20 CONTINUE C DO 30 K=1,L DO 30 I=1,IMAX SSA(I,K) = 0.0 E 0 ASY(I,K) = 0.0 E 0 TAU(I,K) = 0.0 E 0 30 CONTINUE C IF (KAER .LT. 1) RETURN C DO 100 IAER=1,NAE C LAER = .FALSE. DO 40 I=1,IMAX LAER = LAER .OR. PAER(I,IAER).GT.0.0 E 0 40 CONTINUE C write(6,42) IAER C 42 format(2x,'IN AEROS: CALC AEROSOL PROFILE =',I3) IF (.NOT. LAER) GO TO 100 C C===> ... FIND AEROSOL OPTICAL DEPTH, SINGLE SCATTERING ALBEDO C AND ASYMMETRY FACTOR DO 80 K=1,L KK = IDM(K,IAER) HD = HAER(KK,IAER) ZK = ZAER(KK,IAER) IF (HD .GT. 0.0 E 0) THEN TAU0 = ZK * (SIG0(K,IAER)**(HH(K)/HD)) * DZ(K) ELSE TAU0 = (ZK - HD*HH(K)*ALOG(SIG0(K,IAER))) * DZ(K) END IF DO 60 I=1,IMAX TAU(I,K) = TAU(I,K) + PAER(I,IAER)*RAER(IB)*TAU0 SSA(I,K) = SSA(I,K) + PAER(I,IAER)*OAER(KK,IAER,IB) ASY(I,K) = ASY(I,K) + PAER(I,IAER)*GAER(KK,IAER,IB) 60 CONTINUE 80 CONTINUE C 100 CONTINUE C===> ... SMOOTH PROFILE AT DOMAIN BOUNDARIES DO 120 K=2,L DO 120 I=1,IMAX RATIO = 1.0 E 0 IF (TAU(I,K) .GT. 0.0 E 0) RATIO = TAU(I,K-1) / TAU(I,K) TT = TAU(I,K) + TAU(I,K-1) IF (RATIO .GT. CRT1) THEN TAU(I,K) = 0.2 E 0 * TT TAU(I,K-1) = TT - TAU(I,K) ELSE IF (RATIO .LT. CRT2) THEN TAU(I,K) = 0.8 E 0 * TT TAU(I,K-1) = TT - TAU(I,K) END IF 120 CONTINUE C RETURN END c c wne c block data blks PARAMETER ( NDM=6 ) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) D I M E N S I O N 1 HAER(NDM,NAE), ZAER(NDM,NAE) 2, OAER(NDM,NAE,NBD), GAER(NDM,NAE,NBD), RAER(NBD) 4, SIG0(L,NAE), IDM (L,NAE), HH (L) 5, DZ (L), TAUR(L,NBD) C O M M O N /SWAER/ 1 SIG0,HAER,ZAER,HH,DZ,IDM,OAER,GAER,RAER,TAUR C C C --- HAER(NDM,NAE) C DATA HAER 1 / 0.000, 0.000, 0.000,-1.837E-5, 0.000E00, 0.000, 2 0.000, 0.000, 0.000,-1.837E-5, 0.000E00, 0.000, 3 0.000, 0.000, 0.000,-1.837E-5, 0.000E00, 0.000, 4 3.000, 0.000, 0.000,-1.837E-5, 0.000E00, 0.000, 5 0.000, 0.000, 0.000, 0.000E00,-1.837E-5, 0.000, 6 1.000, 0.000, 0.000,-1.837E-5, 0.000E00, 0.000 / C C --- ZAER(NDM,NAE) C DATA ZAER 1 / 0.500, 2.50E-3, 2.18E-4, 2.18E-4, 3.32E-5, 0.00E00, 2 0.100, 2.50E-3, 2.18E-4, 2.18E-4, 3.32E-5, 0.00E00, 3 0.025, 2.50E-3, 2.18E-4, 2.18E-4, 3.32E-5, 0.00E00, C 4 1.157, 2.50E-3, 2.18E-4, 2.18E-4, 3.32E-5, 0.00E00, 4 1.147, 2.50E-3, 2.18E-4, 2.18E-4, 3.32E-5, 0.00E00, 5 0.025, 7.50E-1, 2.50E-3, 2.18E-4, 2.18E-4, 3.32E-5, 6 0.200, 2.50E-3, 2.18E-4, 2.18E-4, 3.32E-5, 0.00E00 / C C --- RAER(NBD) 4 UV+VIS, 4 NIR BANDS (0.55/LAMDA) C DATA RAER / 2.157,2.236,1.763,1.078, 1 .1755,.3152,.5729,.5500 / C C C --- OAER(NDM,NAE,NBD) C 4 UV+VIS BANDS (0.255,0.246,0.312,0.51) DATA ((OAER(I,J,1),I=1,NDM),J=1,NAE) 1 / .599,.786,1.00,1.00,1.00,1.00, .786,.786,1.00,1.00,1.00,1.00, C 1 / .786,.786,1.00,1.00,1.00,1.00, .786,.786,1.00,1.00,1.00,1.00, 2 .924,.786,1.00,1.00,1.00,1.00, .786,.786,1.00,1.00,1.00,1.00, 3 .924,.786,.786,1.00,1.00,1.00, .786,.786,1.00,1.00,1.00,1.00 / DATA ((OAER(I,J,2),I=1,NDM),J=1,NAE) 1 / .588,.765,1.00,1.00,1.00,1.00, .765,.765,1.00,1.00,1.00,1.00, C 1 / .765,.765,1.00,1.00,1.00,1.00, .765,.765,1.00,1.00,1.00,1.00, 2 .912,.765,1.00,1.00,1.00,1.00, .765,.765,1.00,1.00,1.00,1.00, 3 .912,.765,.765,1.00,1.00,1.00, .765,.765,1.00,1.00,1.00,1.00 / DATA ((OAER(I,J,3),I=1,NDM),J=1,NAE) 1 / .659,.890,1.00,1.00,1.00,1.00, .890,.890,1.00,1.00,1.00,1.00, C 1 / .890,.890,1.00,1.00,1.00,1.00, .890,.890,1.00,1.00,1.00,1.00, 2 .979,.890,1.00,1.00,1.00,1.00, .890,.890,1.00,1.00,1.00,1.00, 3 .979,.890,.890,1.00,1.00,1.00, .890,.890,1.00,1.00,1.00,1.00 / DATA ((OAER(I,J,4),I=1,NDM),J=1,NAE) 1 / .651,.897,1.00,1.00,1.00,1.00, .897,.897,1.00,1.00,0.00,1.00, C 1 / .897,.897,1.00,1.00,1.00,1.00, .897,.897,1.00,1.00,1.00,1.00, 2 .990,.897,1.00,1.00,1.00,1.00, .897,.897,1.00,1.00,0.00,1.00, 3 .990,.897,.897,1.00,1.00,1.00, .897,.897,1.00,1.00,0.00,1.00 / C --- 4 NIR BANDS (3.13 1.75 0.96 1.0 MICRON) DATA ((OAER(I,J,5),I=1,NDM),J=1,NAE) 1 / .271,.734,.352,.352,.352,.352, .734,.734,.352,.352,.352,.352, 2 .617,.734,.352,.352,.352,.352, .734,.734,.352,.352,.352,.352, 3 .617,.734,.734,.352,.352,.352, .734,.734,.352,.352,.352,.352 / DATA ((OAER(I,J,6),I=1,NDM),J=1,NAE) 1 / .414,.752,.991,.991,.991,.991, .752,.752,.991,.991,.991,.991, 2 .985,.752,.991,.991,.991,.991, .752,.752,.991,.991,.991,.991, 3 .985,.752,.752,.991,.991,.991, .752,.752,.991,.991,.991,.991 / DATA ((OAER(I,J,7),I=1,NDM),J=1,NAE) 1 / .565,.822,1.00,1.00,1.00,1.00, .822,.822,1.00,1.00,1.00,1.00, 2 .985,.822,1.00,1.00,1.00,1.00, .822,.822,1.00,1.00,1.00,1.00, 3 .985,.822,.822,1.00,1.00,1.00, .822,.822,1.00,1.00,1.00,1.00 / DATA ((OAER(I,J,8),I=1,NDM),J=1,NAE) 1 / .556,.815,1.00,1.00,1.00,1.00, .815,.815,1.00,1.00,1.00,1.00, 2 .985,.815,1.00,1.00,1.00,1.00, .815,.815,1.00,1.00,1.00,1.00, 3 .985,.815,.815,1.00,1.00,1.00, .815,.815,1.00,1.00,1.00,1.00 / C C C --- GAER(NDM,NAE,NBD) C 4 UV+VIS BANDS (0.255,0.246,0.312,0.51) DATA ((GAER(I,J,1),I=1,NDM),J=1,NAE) 1 / .642,.685,.695,.695,.695,.695, .685,.685,.695,.695,.695,.695, 2 .757,.685,.695,.695,.695,.695, .685,.685,.695,.695,.695,.695, 3 .757,.685,.685,.695,.695,.695, .685,.685,.695,.695,.695,.695 / DATA ((GAER(I,J,2),I=1,NDM),J=1,NAE) 1 / .649,.691,.691,.691,.691,.691, .691,.691,.691,.691,.691,.691, 2 .759,.691,.691,.691,.691,.691, .691,.691,.691,.691,.691,.691, 3 .759,.691,.691,.691,.691,.691, .691,.691,.691,.691,.691,.691 / DATA ((GAER(I,J,3),I=1,NDM),J=1,NAE) 1 / .611,.656,.717,.717,.717,.717, .656,.656,.717,.717,.717,.717, 2 .744,.656,.717,.717,.717,.717, .656,.656,.717,.717,.717,.717, 2 .744,.656,.656,.717,.717,.717, .656,.656,.717,.717,.717,.717 / DATA ((GAER(I,J,4),I=1,NDM),J=1,NAE) 1 / .592,.638,.732,.732,.732,.732, .638,.638,.732,.732,.732,.732, 2 .746,.638,.732,.732,.732,.732, .638,.638,.732,.732,.732,.732, 3 .746,.638,.638,.732,.732,.732, .638,.638,.732,.732,.732,.732 / C --- 4 NIR BANDS (3.13 1.75 0.96 1.0 MICRON) DATA ((GAER(I,J,5),I=1,NDM),J=1,NAE) 1 / .589,.787,.147,.147,.147,.147, .787,.787,.147,.147,.147,.147, 2 .786,.787,.147,.147,.147,.147, .787,.787,.147,.147,.147,.147, 3 .786,.787,.787,.147,.147,.147, .787,.787,.147,.147,.147,.147 / DATA ((GAER(I,J,6),I=1,NDM),J=1,NAE) 1 / .572,.673,.388,.388,.388,.388, .673,.673,.388,.388,.388,.388, 2 .777,.673,.388,.388,.388,.388, .673,.673,.388,.388,.388,.388, 3 .777,.673,.673,.388,.388,.388, .673,.673,.388,.388,.388,.388 / DATA ((GAER(I,J,7),I=1,NDM),J=1,NAE) 1 / .580,.632,.621,.621,.621,.621, .632,.632,.621,.621,.621,.621, 2 .757,.632,.621,.621,.621,.621, .632,.632,.621,.621,.621,.621, 3 .757,.632,.632,.621,.621,.621, .632,.632,.621,.621,.621,.621 / DATA ((GAER(I,J,8),I=1,NDM),J=1,NAE) 1 / .579,.632,.609,.609,.609,.609, .632,.632,.609,.609,.609,.609, 2 .758,.632,.609,.609,.609,.609, .632,.632,.609,.609,.609,.609, 3 .758,.632,.632,.609,.609,.609, .632,.632,.609,.609,.609,.609 / end c---------------------------------------------------------------- SUBROUTINE GAEROS(SI,SL) CFPP$ NOCONCUR R C******************************************************************** C SETUP COMMON BLOCK 'SWAER' FOR AEROSOLS AND RAYLEIGH SCATTERING C OPTICAL PROPERTIES IN FOUR UV+VIS BANDS AND FOUR NIR BANDS. C BAND: 1. 0.225-0.285 (UV) 2. 0.175-0.225;0.285-0.300 (UV) C 3. 0.300-0.325 (UV0 4. 0.325-0.690 (PAR) C 5. 2.27 - 4.0 (NIR) 6. 1.22 - 2.27 (NIR) C 7. 0.70 - 1.22 (NIR) 8. 0.70 - 4.0 (NIR) C REF: WMO REPORT WCP-112 (1986) C C THE SIX TYPICAL AEROSOL PROFILES: C 1.UBR; 2.CONT-1; 3.MAR-1; 4.CONT-2; 5.MAR-2; 6.CONV C C SIGREF - REF. SIGMA LEVEL N/D NDM*NAE C ARRAYS IN THE COMMON BLOCK: C SIG0 - RATIO OF SIGL TO DOMAIN BOUNDARY N/D L*NAE C HAER - SCALE HEIGHT OF AEROSOLS KM NDM*NAE C ZAER - EXT. COEF. OF AEROSOLS 1/KM NDM*NAE C HH - ATMOSPHERIC SCALE HEIGHT KM L C DZ - LAYER THICKNESS KM L C IDM - DOMAIN INDEX N/D L*NAE C OAER - SINGLE SCATTERING ALBEDO N/D NDM*NAE*NBD C GAER - ASYMMETRY PARAMETER N/D NDM*NAE*NBD C RAER - RATIO OF BAND WAVELENGTH TO THE C REFFERENCE WAVELENGTH (0.55 MICRON)N/D NBD C TAUR - RAYLEIGH SCATTERING OPTICAL DEPTH N/D L*NBD C******************************************************************** C PARAMETER ( NDM=6 ) C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) D I M E N S I O N 1 SIGREF(NDM,NAE), HAER(NDM,NAE), ZAER(NDM,NAE) 2, OAER(NDM,NAE,NBD), GAER(NDM,NAE,NBD), RAER(NBD) 3, SI (LP1), SL (L), SIGLN(LP1) 4, SIG0(L,NAE), IDM (L,NAE), HH (L) 5, DZ (L), TAUR(L,NBD), TAURAY(NBD) C O M M O N /SWAER/ 1 SIG0,HAER,ZAER,HH,DZ,IDM,OAER,GAER,RAER,TAUR C C --- TAURAY(NBD) C DATA TAURAY 1 / 2.370, 2.180, 0.986, 0.134 2, .289E-3, .375E-2, .354E-1, .128E-1 / C 2, .723E-4, .868E-3, .103E-1, .838E-2 / C C --- SIGREF(NDM,NAE) C DATA SIGREF 1 / 0.780, 0.160, 0.047, 0.010, 0.001, 0.000, 2 0.780, 0.160, 0.047, 0.010, 0.001, 0.000, 3 0.780, 0.160, 0.047, 0.010, 0.001, 0.000, 4 0.470, 0.160, 0.047, 0.010, 0.001, 0.000, 5 0.780, 0.470, 0.160, 0.047, 0.010, 0.001, 6 0.580, 0.160, 0.047, 0.010, 0.001, 0.000 / C C C===> ... COMPUTE LAYER DISTRIBUTIONS OF RAYLEIGH SCATTERING C DO 10 N=1,NBD DO 10 K=1,L TAUR(K,N) = TAURAY(N) * (SI(LP1-K)-SI(LP1-K+1)) 10 CONTINUE C C===> ... SETUP LOG SIGMA ARRAY (SET TOA SIGMA=0.0001) C REM: SI,SL K=1 IS SFC; BUT IN RADIATION K=1 IS TOA SIGLN(1) = ALOG(1.0 E -4) DO 20 K=1,L SIGLN(K+1) = ALOG(SI(LP1-K)) 20 CONTINUE DO 30 K=1,L HH(K) = 6.05 E 0 + 2.5 E 0 * SL(LP1-K) DZ(K) = HH(K) * (SIGLN(K+1)-SIGLN(K)) 30 CONTINUE C DO 60 IAER=1,NAE SBUND= SI(1) IDOM = 1 DO 50 K=L,1,-1 IF (SI(LP1-K+1) .LT. SIGREF(IDOM,IAER)) THEN IDOM = IDOM + 1 SBUND= SI(LP1-K) END IF SIG0(K,IAER) = SL(LP1-K) / SBUND IDM (K,IAER) = IDOM 50 CONTINUE 60 CONTINUE C RETURN END SUBROUTINE FLXCO2(SWC,SWH,CSM,DAYTM,DFLX) CFPP$ NOCONCUR R C******************************************************************** C COMPUTE THE ABSORPTION DUE TO CO2. REF: CHOU (J. CLIMATE, 1990, C 209-217) C THE EFFECT OF CO2 ABSORPTION BELOW THE CLOUD TOP IS NEGLECTED. C INPUT VARIABLES: C SWC,SWH : COLUMN AMOUNT OF CO2 AND WATER VAPOR C CSM : SECANT OF SOLAR ZENITH ANGLE C DAYTM : DAYTIME FLAG C OUTPUT VARIABLES: C DFLX : FLUX REDUCTION DUE TO CO2 FOR CLEAR SKY C C******************************************************************** C C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE: C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS. C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE C BANDTA FOR DEFINITION C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE C BDCOMB FOR DEFINITION C INLTE = NO. LEVELS USED FOR NLTE CALCS. C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS. C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED C FROM THE ABOVE PARAMETERS. PARAMETER (L= 28 ) PARAMETER (IMAX= 64 ) PARAMETER (IMBX=IMAX) PARAMETER (NBLW=163,NBLX=47,NBLY=15) PARAMETER (NBLM=NBLY-1) PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3) PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3) PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3) PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3) PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1) PARAMETER (LP1V=LP1*(1+2*L/2)) PARAMETER (LP121=LP1*NBLY) PARAMETER (LL3P=3*L+2) PARAMETER (NB=12) PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56) PARAMETER (NB1=NB-1) PARAMETER (KO2=12) PARAMETER (KO21=KO2+1,KO2M=KO2-1) C - FOR 8 UV BANDS SW C PARAMETER (NBD=12,NVB=8,NRB=4,NK0=10,NAE=6,NSRC=5) C - FOR 4 UV BANDS SW PARAMETER (NBD=8,NVB=4,NRB=4,NK0=10,NAE=6,NSRC=5) D I M E N S I O N 1 CSM(IMAX), SWC(IMBX,L), SWH(IMBX,L) 2, DFLX(IMBX,LP1), CAH(22,19) LOGICAL DAYTM(IMAX) C ... CO2 LOOK-UP TABLE ............. DATA (CAH(I,1), I=1,22) / 0.9923,0.9922,0.9921,0.9920, 1 0.9916,0.9910,0.9899,0.9882,0.9856,0.9818,0.9761,0.9678,0.9558, 1 0.9395,0.9188,0.8945,0.8675,0.8376,0.8029,0.7621,0.7154,0.6647 / 2, (CAH(I,2), I=1,22) / 0.9876,0.9876,0.9875,0.9873, 2 0.9870,0.9864,0.9854,0.9837,0.9811,0.9773,0.9718,0.9636,0.9518, 2 0.9358,0.9153,0.8913,0.8647,0.8350,0.8005,0.7599,0.7133,0.6627 / 3, (CAH(I,3), I=1,22) / 0.9808,0.9807,0.9806,0.9805, 3 0.9802,0.9796,0.9786,0.9769,0.9744,0.9707,0.9653,0.9573,0.9459, 3 0.9302,0.9102,0.8866,0.8604,0.8311,0.7969,0.7565,0.7101,0.6596 / C DATA (CAH(I,4), I=1,22) / 0.9708,0.9708,0.9707,0.9705, 1 0.9702,0.9697,0.9687,0.9671,0.9647,0.9612,0.9560,0.9483,0.9372, 1 0.9221,0.9027,0.8798,0.8542,0.8253,0.7916,0.7515,0.7054,0.6551 / 2, (CAH(I,5), I=1,22) / 0.9568,0.9568,0.9567,0.9565, 2 0.9562,0.9557,0.9548,0.9533,0.9510,0.9477,0.9428,0.9355,0.9250, 2 0.9106,0.8921,0.8700,0.8452,0.8171,0.7839,0.7443,0.6986,0.6486 / 3, (CAH(I,6), I=1,22) / 0.9377,0.9377,0.9376,0.9375, 3 0.9372,0.9367,0.9359,0.9345,0.9324,0.9294,0.9248,0.9181,0.9083, 3 0.8948,0.8774,0.8565,0.8328,0.8055,0.7731,0.7342,0.6890,0.6395 / C DATA (CAH(I,7), I=1,22) / 0.9126,0.9126,0.9125,0.9124, 1 0.9121,0.9117,0.9110,0.9098,0.9079,0.9052,0.9012,0.8951,0.8862, 1 0.8739,0.8579,0.8385,0.8161,0.7900,0.7585,0.7205,0.6760,0.6270 / 2, (CAH(I,8), I=1,22) / 0.8809,0.8809,0.8808,0.8807, 2 0.8805,0.8802,0.8796,0.8786,0.8770,0.8747,0.8712,0.8659,0.8582, 2 0.8473,0.8329,0.8153,0.7945,0.7697,0.7394,0.7024,0.6588,0.6105 / 3, (CAH(I,9), I=1,22) / 0.8427,0.8427,0.8427,0.8426, 3 0.8424,0.8422,0.8417,0.8409,0.8397,0.8378,0.8350,0.8306,0.8241, 3 0.8148,0.8023,0.7866,0.7676,0.7444,0.7154,0.6796,0.6370,0.5897 / C DATA (CAH(I,10), I=1,22) / 0.7990,0.7990,0.7990,0.7989, 1 0.7988,0.7987,0.7983,0.7978,0.7969,0.7955,0.7933,0.7899,0.7846, 1 0.7769,0.7664,0.7528,0.7357,0.7141,0.6866,0.6520,0.6108,0.5646 / 2, (CAH(I,11), I=1,22) / 0.7515,0.7515,0.7515,0.7515, 2 0.7514,0.7513,0.7511,0.7507,0.7501,0.7491,0.7476,0.7450,0.7409, 2 0.7347,0.7261,0.7144,0.6992,0.6793,0.6533,0.6203,0.5805,0.5357 / 3, (CAH(I,12), I=1,22) / 0.7020,0.7020,0.7020,0.7019, 3 0.7019,0.7018,0.7017,0.7015,0.7011,0.7005,0.6993,0.6974,0.6943, 3 0.6894,0.6823,0.6723,0.6588,0.6406,0.6161,0.5847,0.5466,0.5034 / C DATA (CAH(I,13), I=1,22) / 0.6518,0.6518,0.6518,0.6518, 1 0.6518,0.6517,0.6517,0.6515,0.6513,0.6508,0.6500,0.6485,0.6459, 1 0.6419,0.6359,0.6273,0.6151,0.5983,0.5755,0.5458,0.5095,0.4681 / 2, (CAH(I,14), I=1,22) / 0.6017,0.6017,0.6017,0.6017, 2 0.6016,0.6016,0.6016,0.6015,0.6013,0.6009,0.6002,0.5989,0.5967, 2 0.5932,0.5879,0.5801,0.5691,0.5535,0.5322,0.5043,0.4700,0.4308 / 3, (CAH(I,15), I=1,22) / 0.5518,0.5518,0.5518,0.5518, 3 0.5518,0.5518,0.5517,0.5516,0.5514,0.5511,0.5505,0.5493,0.5473, 3 0.5441,0.5393,0.5322,0.5220,0.5076,0.4878,0.4617,0.4297,0.3929 / C DATA (CAH(I,16), I=1,22) / 0.5031,0.5031,0.5031,0.5031, 1 0.5031,0.5030,0.5030,0.5029,0.5028,0.5025,0.5019,0.5008,0.4990, 1 0.4960,0.4916,0.4850,0.4757,0.4624,0.4441,0.4201,0.3904,0.3564 / 2, (CAH(I,17), I=1,22) / 0.4565,0.4565,0.4565,0.4564, 2 0.4564,0.4564,0.4564,0.4563,0.4562,0.4559,0.4553,0.4544,0.4527, 2 0.4500,0.4460,0.4400,0.4315,0.4194,0.4028,0.3809,0.3538,0.3227 / 3, (CAH(I,18), I=1,22) / 0.4122,0.4122,0.4122,0.4122, 3 0.4122,0.4122,0.4122,0.4121,0.4120,0.4117,0.4112,0.4104,0.4089, 3 0.4065,0.4029,0.3976,0.3900,0.3792,0.3643,0.3447,0.3203,0.2923 / C DATA (CAH(I,19), I=1,22) / 0.3696,0.3696,0.3696,0.3696, 1 0.3696,0.3696,0.3695,0.3695,0.3694,0.3691,0.3687,0.3680,0.3667, 1 0.3647,0.3615,0.3570,0.3504,0.3409,0.3279,0.3106,0.2892,0.2642 / C ... TABLE LOOK-UP FOR THE ABSORPTION DUE TO CO2 C 0.0343 IS THE FRACTION OF SOLAR FLUX IN THE CO2 BANDS C DF IS THE ABSORPTION OF SOLAR RADIATION DUE TO CO2 C C --- FLUX REDUCTION DUE TO CO2 XX = 1.0 E 0 / 0.3 E 0 DO 20 K=2,LP1 DO 20 I=1,IMAX IF (DAYTM(I)) THEN CLOG = ALOG10(SWC(I,K) / CSM(I)) WLOG = ALOG10(SWH(I,K) / CSM(I)) IC = INT( (CLOG+3.15 E 0) * XX + 1.0 E 0) IW = INT( (WLOG+4.15 E 0) * XX + 1.0 E 0) IC = MAX(2, MIN(22, IC)) IW = MAX(2, MIN(19, IW)) IC1 = IC - 1 IW1 = IW - 1 DC = (3.0 + CLOG) * XX - FLOAT(IC-2) DW = (4.0 + WLOG) * XX - FLOAT(IW-2) X1 = CAH(1, IW1) + (CAH(1, IW) - CAH(1, IW1)) * DW X2 = CAH(IC1,IW1) + (CAH(IC1,IW) - CAH(IC1,IW1)) * DW Y2 = X2 + (CAH(IC,IW1) - CAH(IC1,IW1)) * DC DFLX(I,K) = DFLX(I,K) + 0.0343 * AMAX1(0.0, X1-Y2) END IF 20 CONTINUE C RETURN END SUBROUTINE TREAD(N,FHOUR,IDATE,GZ,Q,TE,DI,ZE,RQ,SL,SI,Z00) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TREAD READS SIGMA LEVEL SPECTRAL COEFFICIENTS. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-27 C C ABSTRACT: READS A COMPLETE SET OF SIGMA LEVEL SPECTRAL COEFFICIENTS C AT A SINGLE TIME TO BE USED TO START THE MODEL FORECAST. C THE SUBROUTINE COMPARES SI AND SL (THE MODEL'S VERTICAL C STRUCTURE) COMPUTED IN SETSIG WITH THE SI AND SL OF THE C INPUT COEFFICIENTS IN ORDER TO MAKE SURE THE COEFFICIENTS C WERE GENERATED UNDER THE SAME VERTICAL STRUCTURE. C C PROGRAM HISTORY LOG: C 88-04-27 JOSEPH SELA C C USAGE: CALL TREAD (N,FHOUR,IDATE,GZ,Q,TE,DI,ZE,RQ,SL,SI,Z00) C INPUT ARGUMENT LIST: C N - FORTRAN UNIT NUMBER FOR FILE CONTAINING THE C COMPLETE SET OF SIGMA LEVEL COEFFICIENTS. C SL - SIGMA LAYERS COMPUTED IN SETSIG. C SI - SIGMA INTERFACES COMPUTED IN SETSIG. C C OUTPUT ARGUMENT LIST: C FHOUR - FORECAST HOUR OF THE SET OF COEFFICIENTS READ C FROM UNIT N. C IDATE - IDATE(1)=INITIAL HOUR (GMT) OF FORECAST FROM C WHICH COEFFICIENTS WERE MADE. C IDATE(2)=MONTH (1-12). C IDATE(3)=DAY OF THE MONTH. C IDATE(4)=YEAR OF THE CENTURY. C GZ - LAPLACIAN OF TOPOGRAPHY. C GZ IS MULTIPLIED BY THE CONSTANT SNNP1 ARRAY. C GZ IS THEN MULTIPLIED BY THE GRAVITY CONSTANT AND C DIVIDED BY THE SQUARE OF THE RADIUS OF THE EARTH. C Q - LN(PSFC) COEFFICIENTS. C TE - TEMPERATURE COEFFICIENTS. C DI - DIVERGENCE COEFFICIENTS. C ZE - VORTICITY COEFFICIENTS. C RQ - SPECIFIC HUMIDITY COEFFICIENTS. C Z00 - MEAN TOPOGRAPHY. C Z00 IS SET EQUAL TO GZ(1) AFTER GZ IS READ. C C INPUT FILES: C UNIT N - COMPLETE SET OF SIGMA LEVEL SPECTRAL COEFFICIENTS. C C OUTPUT FILES: C OUTPUT - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB DIMENSION 1 GZ( 4033 ), 2 Q( 4033 ), 3 TE( 4033 , 28 ),DI( 4033 , 28 ),ZE( 4033 , 28 ), 4 RQ( 4033 , 28 ) DIMENSION IDATE(4),SI( 29 ),SL( 28 ) DIMENSION XI( 29 ),XL( 28 ) DIMENSION DUMMY(201- 29 - 28 ) DIMENSION ENSEMBLE(2),DUMMY2(21) C C ADDITION BY MK 4/5/90 C SAVE IFP DATA IFP/0/ C IF(IFP.EQ.0) THEN CALL CMPIND IFP=1 ENDIF C C END ADDITION C C SPECTRAL DATA FILE FORMAT C.....LAB C.....HOUR,IDATE(4),SI( 29 ),SL( 28 ) C.....ZLN Q TE DI ZE READ(N)LAB C PRINT 3000,LAB,N 3000 FORMAT(1H0,'TREAD LAB ',4A10,' N=',I3) READ(N)FHOUR,IDATE,(XI(K),K=1, 29 ),(XL(K),K=1, 28 ) C & ,DUMMY,WAVES,XLAYERS,TRUN,ORDER,REALFORM,GENCODE C & ,RLOND,RLATD,RLONP,RLATP,RLONR,RLATR,TRACERS C & ,SUBCEN,ENSEMBLE,PPID,SLID,VCID,VMID,VTID,RUNID,USRID C & ,DUMMY2 C IF(IGEN.EQ.0) IGEN=GENCODE PRINT *,'TREAD UNIT,FHOUR,IDATE=',N,FHOUR,IDATE READ(N)(GZ(I),I=1, 4032 ) C Z00=GZ(1) DO 300 J=1, 4032 GZ(J)=GZ(J)*SNNP1(J) 300 CONTINUE GA2= 9.8000E+0 /( 6.3712E+6 * 6.3712E+6 ) DO 350 J=1, 4032 GZ(J)=GZ(J)*GA2 350 CONTINUE CALL BARTRI(GZ,GZ,GZBAR) PRINT 99,GZBAR 99 FORMAT(1H ,'LAP(GZ)=',E12.3) C READ(N)(Q(I),I=1, 4032 ) DO 400 K=1, 28 READ(N)(TE(I,K),I=1, 4032 ) 400 CONTINUE DO 401 K=1, 28 READ(N)(DI(I,K),I=1, 4032 ) READ(N)(ZE(I,K),I=1, 4032 ) 401 CONTINUE DO 200 K=1, 28 READ(N)(RQ(I,K),I=1, 4032 ) 200 CONTINUE C DO 3 K=1, 28 XL(K)=XL(K)-SL(K) 3 CONTINUE PRINT 100,(XL(K),K=1, 28 ) DO 4 K=1, 29 XI(K)=XI(K)-SI(K) 4 CONTINUE C-DBG PRINT 100,(XI(K),K=1, 29 ) 100 FORMAT(1H0, 12 (E9.3)) C-DBG PRINT 101,N,FHOUR,IDATE,Z00 101 FORMAT (1H0, 'IF ABOVE TWO ROWS NOT ZERO,INCONSISTENCY IN SIG.DEF' 1,'ON N=',I2,2X,F6.1,2X,4(I4),'Z00=',E12.4) RETURN END SUBROUTINE EXTREM(A,B,LGTH,IND) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: EXTREM PRINTS MINIMUMS AND MAXIMUMS OF 2 ARRAYS. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-01 C C ABSTRACT: PRINTS MINIMUMS AND MAXIMUMS OF 2 ARRAYS. C C PROGRAM HISTORY LOG: C 88-04-01 JOSEPH SELA C C USAGE: CALL EXTREM (A, B, LGTH, IND) C INPUT ARGUMENT LIST: C A - FINDS AND PRINTS MINIMUM AND MAXIMUM OF ARRAY A. C B - FINDS AND PRINTS MINIMUM AND MAXIMUM OF ARRAY B. C LGTH - LENGTH OF ARRAY A AND ARRAY B. C IND - INDICATOR PRINTED WITH MINIMUMS AND MAXIMUMS. C C OUTPUT FILES: C OUTPUT - PRINTOUT FILE. C C REMARKS: LGTH SHOULD BE GREATER THAN 1. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200 C MACHINE: CYBER 205 C C$$$ DIMENSION A(LGTH), B(LGTH) AMIN = A(1) AMAX = A(1) DO 25 I=2,LGTH IF (A(I).GT.AMAX) AMAX = A(I) IF (A(I).LT.AMIN) AMIN = A(I) 25 CONTINUE C BMIN = B(1) BMAX = B(1) DO 50 I=2,LGTH IF (B(I).GT.BMAX) BMAX = B(I) IF (B(I).LT.BMIN) BMIN = B(I) 50 CONTINUE PRINT 100,IND,AMIN,AMAX,BMIN,BMAX 100 FORMAT(1H ,'IND AMIN AMAX BMIN BMAX ',I4,2X,4(E12.4,2X)) RETURN END SUBROUTINE ROW1NS(A) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ROW1NS PAIR NORTHERN AND SOUTHERN LATITUDES. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-12 C C ABSTRACT: PAIR NORTHERN AND SOUTHERN LATITUDES OF GAUSSIAN GRID. C C PROGRAM HISTORY LOG: C 88-04-12 JOSEPH SELA C C USAGE: CALL ROW1NS (A) C INPUT ARGUMENT LIST: C A - ARRAY OF GAUSSIAN GRID WITH SEPARATED C NORTHERN AND SOUTHERN LATITUDES. C INPUT ARRAY IS OVERWRITTEN BY OUTPUT ARRAY. C C OUTPUT ARGUMENT LIST: C A - ARRAY OF GAUSSIAN GRID WITH PAIRED C NORTHERN AND SOUTHERN LATITUDES. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ DIMENSION A( 192 , 94 ) DIMENSION B( 192 ),JDONE( 94 ) DO 1 K=1, 94 JDONE(K)=0 1 CONTINUE JSAVE=2 3 CONTINUE IF(MOD(JSAVE,2).EQ.0) THEN JGET= 94 +1-JSAVE/2 ELSE JGET=(JSAVE+1)/2 ENDIF IF(JGET.EQ.JSAVE) THEN JDONE(JSAVE)=1 GO TO 35 ENDIF DO 5 J=1, 192 B(J)=A(J,JSAVE) A(J,JSAVE)=A(J,JGET) 5 CONTINUE JDONE(JSAVE)=1 10 CONTINUE JPUT=JGET IF(MOD(JPUT,2).EQ.0) THEN JGET= 94 +1-JPUT/2 ELSE JGET=(JPUT+1)/2 ENDIF IF(JGET.EQ.JSAVE) GO TO 20 DO 15 J=1, 192 A(J,JPUT)=A(J,JGET) 15 CONTINUE JDONE(JPUT)=1 GO TO 10 20 CONTINUE DO 30 J=1, 192 A(J,JPUT)=B(J) 30 CONTINUE JDONE(JPUT)=1 35 CONTINUE DO 40 K=JSAVE, 94 IF(JDONE(K).EQ.0) THEN JSAVE=K GO TO 3 ENDIF 40 CONTINUE RETURN END SUBROUTINE ROWSEP(A) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ROWSEP SEPARATE NORTHERN AND SOUTHERN LATITUDES. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-12 C C ABSTRACT: SEPARATE NORTHERN AND SOUTHERN LATITUDES OF GAUSSIAN GRID. C C PROGRAM HISTORY LOG: C 88-04-12 JOSEPH SELA C C USAGE: CALL ROWSEP (A) C INPUT ARGUMENT LIST: C A - ARRAY OF GAUSSIAN GRID WITH PAIRED C NORTHERN AND SOUTHERN LATITUDES. C INPUT ARRAY IS OVERWRITTEN BY OUTPUT ARRAY. C C OUTPUT ARGUMENT LIST: C A - ARRAY OF GAUSSIAN GRID WITH SEPARATED C NORTHERN AND SOUTHERN LATITUDES. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ DIMENSION A( 192 , 94 ) DIMENSION B( 192 ),JDONE( 94 ) DO 1 K=1, 94 JDONE(K)=0 1 CONTINUE JSAVE=2 3 CONTINUE IF(JSAVE.LE. 47 ) THEN JGET=2*JSAVE-1 ELSE JGET=2*( 94 +1-JSAVE) ENDIF IF(JGET.EQ.JSAVE) THEN JDONE(JSAVE)=1 GO TO 35 ENDIF DO 5 J=1, 192 B(J)=A(J,JSAVE) A(J,JSAVE)=A(J,JGET) 5 CONTINUE JDONE(JSAVE)=1 10 CONTINUE JPUT=JGET IF(JPUT.LE. 47 ) THEN JGET=2*JPUT-1 ELSE JGET=2*( 94 +1-JPUT) ENDIF IF(JGET.EQ.JSAVE) GO TO 20 DO 15 J=1, 192 A(J,JPUT)=A(J,JGET) 15 CONTINUE JDONE(JPUT)=1 GO TO 10 20 CONTINUE DO 30 J=1, 192 A(J,JPUT)=B(J) 30 CONTINUE JDONE(JPUT)=1 35 CONTINUE DO 40 K=JSAVE, 94 IF(JDONE(K).EQ.0) THEN JSAVE=K GO TO 3 ENDIF 40 CONTINUE RETURN END SUBROUTINE ROWSNS(A,B) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ROWSNS PAIR NORTHERN AND SOUTHERN LATITUDES. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-12 C C ABSTRACT: PAIR NORTHERN AND SOUTHERN LATITUDES OF GAUSSIAN GRIDS. C THIS SUBROUTINE DOES MULTIPLE GRIDS. C C PROGRAM HISTORY LOG: C 88-04-12 JOSEPH SELA C C USAGE: CALL ROWSNS (A, B) C INPUT ARGUMENT LIST: C A - ARRAY OF LEVS GAUSSIAN GRIDS WITH SEPARATED C NORTHERN AND SOUTHERN LATITUDES. C C OUTPUT ARGUMENT LIST: C B - ARRAY OF LEVS GAUSSIAN GRIDS WITH PAIRED C NORTHERN AND SOUTHERN LATITUDES. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ DIMENSION A( 192 , 28 , 94 ),B( 384 , 28 , 47 ) DO 10 LAT=1, 47 DO 5 K=1, 28 DO 220 J=1, 192 B(J,K,LAT)=A(J,K,LAT) 220 CONTINUE DO 240 J=1, 192 B(J+ 192 ,K,LAT)=A(J,K, 94 +1-LAT) 240 CONTINUE 5 CONTINUE 10 CONTINUE RETURN END SUBROUTINE TWRITE(N,FHOUR,IDATE,Z,Q,TE,DI,ZE,RQ,SL,SI,GZ,Z00,NZ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TWRITE WRITES SIGMA LEVEL SPECTRAL COEFFICIENTS. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-29 C C ABSTRACT: WRITES A COMPLETE SET OF FORECAST SIGMA LEVEL C SPECTRAL COEFFICIENTS FOR ALL MODEL VARIABLES. C C PROGRAM HISTORY LOG: C 88-04-29 JOSEPH SELA C 88-11-02 MARK ROZWODOSKI CHANGED SECOND RECORD TO SELALABEL. C C USAGE: CALL TWRITE (N,FHOUR,IDATE,Z,Q,TE,DI,ZE,RQ,SL,SI,GZ,Z00) C INPUT ARGUMENT LIST: C N - FORTRAN UNIT NUMBER FOR FILE TO BE WRITTEN TO. C FHOUR - FORECAST HOUR OF THE SET OF COEFFICIENTS. C IDATE - IDATE(1)=INITIAL HOUR (GMT) OF FORECAST. C IDATE(2)=MONTH (1-12). C IDATE(3)=DAY OF THE MONTH. C IDATE(4)=YEAR OF THE CENTURY. C Q - LN(PSFC) COEFFICIENTS. C TE - TEMPERATURE COEFFICIENTS. C DI - DIVERGENCE COEFFICIENTS. C ZE - VORTICITY COEFFICIENTS. C RQ - SPECIFIC HUMIDITY COEFFICIENTS. C SL - SIGMA LAYERS COMPUTED IN SETSIG. C SI - SIGMA INTERFACES COMPUTED IN SETSIG. C GZ - LAPLACIAN OF TOPOGRAPHY. C Z00 - MEAN TOPOGRAPHY. C C OUTPUT ARGUMENT LIST: C Z - TOPOGRAPHY SPECTRAL COEFFICIENTS. C C OUTPUT FILES: C UNIT N - COMPLETE SET OF FORECAST SIGMA LEVEL SPECTRAL C COEFFICIENTS. C OUTPUT - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB DIMENSION 1 Z( 4033 ),GZ( 4033 ),Q( 4033 ), 2 TE( 4033 , 28 ),DI( 4033 , 28 ),ZE( 4033 , 28 ), 3 RQ( 4033 , 28 ) DIMENSION IDATE(4),SI( 29 ),SL( 28 ) C DIMENSION DUMMY(201- 29 - 28 ) DIMENSION ENSEMBLE(2),DUMMY2(21) C C WRITE(N)LAB C PRINT 3000,LAB,N 3000 FORMAT(1H0,'GWRITE LAB ',4A10,' N=',I3) DO K=1,201- 29 - 28 DUMMY(K)=0. ENDDO WAVES= 62 XLAYERS= 28 TRUN=1. ORDER=2. REALFORM=1. GENCODE=IGEN RLOND= 192 RLATD= 94 RLONP= 192 RLATP= 94 RLONR= 192 RLATR= 94 TRACERS=1 SUBCEN=ICEN2 ENSEMBLE(1)=IENST ENSEMBLE(2)=IENSI PPID=0 SLID=0 VCID=0 VMID=0 VTID=0 DO K=1,21 DUMMY2(K)=0 ENDDO WRITE(N)FHOUR,IDATE,SI,SL & ,DUMMY,WAVES,XLAYERS,TRUN,ORDER,REALFORM,GENCODE & ,RLOND,RLATD,RLONP,RLATP,RLONR,RLATR,TRACERS & ,SUBCEN,ENSEMBLE,PPID,SLID,VCID,VMID,VTID,RUNID,USRID & ,DUMMY2 C C... COMPUTE TOPOG. FROM ITS LAPLACIAN CMI-CHANGED TO READ OROG FROM INPUT (OCT 92) C ASQ= 6.3712E+6 * 6.3712E+6 / 9.8000E+0 C DO 200 J=3, 4032 C Z(J)=GZ(J)*ASQ/SNNP1(J) 200 CONTINUE C Z(1)=Z00 C Z(2)=0. E 0 REWIND NZ READ(NZ) READ(NZ) READ(NZ)( Z(I),I=1, 4032 ) C WRITE(N)( Z(I),I=1, 4032 ) WRITE(N)( Q(I),I=1, 4032 ) DO 15 K=1, 28 WRITE(N)(TE(I,K),I=1, 4032 ) 15 CONTINUE DO 20 K=1, 28 WRITE(N)(DI(I,K),I=1, 4032 ) WRITE(N)(ZE(I,K),I=1, 4032 ) 20 CONTINUE DO 25 K=1, 28 WRITE(N)(RQ(I,K),I=1, 4032 ) 25 CONTINUE PRINT 3001,FHOUR,IDATE,N 3001 FORMAT(1H0,'GWRITE FHOUR=',F6.2,2X,4I4,2X,'N=',I2) RETURN END CFPP$ NOCONCUR R C----------------------------------------------------------------------- SUBROUTINE TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TRIDI2 SOLVES TRIDIAGONAL MATRIX PROBLEMS. C PRGMMR: IREDELL ORG: W/NMC23 DATE: 91-05-07 C C ABSTRACT: THIS ROUTINE SOLVES MULTIPLE TRIDIAGONAL MATRIX PROBLEMS C WITH 2 RIGHT-HAND-SIDE AND SOLUTION VECTORS FOR EVERY MATRIX. C THE SOLUTIONS ARE FOUND BY ELIMINATING OFF-DIAGONAL COEFFICIENTS, C MARCHING FIRST FOREWARD THEN BACKWARD ALONG THE MATRIX DIAGONAL. C THE COMPUTATIONS ARE VECTORIZED AROUND THE NUMBER OF MATRICES. C NO CHECKS ARE MADE FOR ZEROES ON THE DIAGONAL OR SINGULARITY. C C PROGRAM HISTORY LOG: C 91-05-07 IREDELL C C USAGE: CALL TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2) C C INPUT ARGUMENT LIST: C L - INTEGER NUMBER OF TRIDIAGONAL MATRICES C N - INTEGER ORDER OF THE MATRICES C CL - REAL (L,2:N) LOWER DIAGONAL MATRIX ELEMENTS C CM - REAL (L,N) MAIN DIAGONAL MATRIX ELEMENTS C CU - REAL (L,N-1) UPPER DIAGONAL MATRIX ELEMENTS C (MAY BE EQUIVALENT TO AU IF NO LONGER NEEDED) C R1 - REAL (L,N) 1ST RIGHT-HAND-SIDE VECTOR ELEMENTS C (MAY BE EQUIVALENT TO A1 IF NO LONGER NEEDED) C R2 - REAL (L,N) 2ND RIGHT-HAND-SIDE VECTOR ELEMENTS C (MAY BE EQUIVALENT TO A2 IF NO LONGER NEEDED) C C OUTPUT ARGUMENT LIST: C AU - REAL (L,N-1) WORK ARRAY C A1 - REAL (L,N) 1ST SOLUTION VECTOR ELEMENTS C A2 - REAL (L,N) 2ND SOLUTION VECTOR ELEMENTS C C REMARKS: THIS ROUTINE CAN BE EASILY MODIFIED TO SOLVE A DIFFERENT C NUMBER OF RIGHT-HAND-SIDES AND SOLUTIONS PER MATRIX BESIDES 2. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY. C C$$$ DIMENSION CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), & AU(L,N-1),A1(L,N),A2(L,N) C----------------------------------------------------------------------- DO I=1,L FK=1./CM(I,1) AU(I,1)=FK*CU(I,1) A1(I,1)=FK*R1(I,1) A2(I,1)=FK*R2(I,1) ENDDO DO K=2,N-1 DO I=1,L FK=1./(CM(I,K)-CL(I,K)*AU(I,K-1)) AU(I,K)=FK*CU(I,K) A1(I,K)=FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) A2(I,K)=FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) ENDDO ENDDO DO I=1,L FK=1./(CM(I,N)-CL(I,N)*AU(I,N-1)) A1(I,N)=FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) A2(I,N)=FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) ENDDO DO K=N-1,1,-1 DO I=1,L A1(I,K)=A1(I,K)-AU(I,K)*A1(I,K+1) A2(I,K)=A2(I,K)-AU(I,K)*A2(I,K+1) ENDDO ENDDO C----------------------------------------------------------------------- RETURN END SUBROUTINE UVTODZ(ULN,VLN,DI,ZE,TOPULN,TOPVLN) PARAMETER (JCAP= 62 ) DIMENSION DI( 4033 , 28 ) DIMENSION ZE( 4033 , 28 ) DIMENSION ULN( 4033 , 28 ) DIMENSION VLN( 4033 , 28 ) DIMENSION EPS( 4033 ) DIMENSION TOPULN(2,0: 62 , 28 ) DIMENSION TOPVLN(2,0: 62 , 28 ) DIMENSION TOPEPS(0: 62 ) C SAVE IFIRST,EPS,TOPEPS C C LOCAL SCALARS C ------------- C INTEGER I, N, L, K C C STATEMENT FUNCTIONS C ------------------- C C OFFSET(N,L) IS THE OFFSET IN WORDS C TO THE (N,L)-ELEMENT OF A LOWER C TRIANGULAR MATRIX OF COMPLEX NUMBERS C IN AN ARRAY CONTAINING THE MATRIX C PACKED IN COLUMN-MAJOR ORDER, C WHERE L AND N RANGE FROM 0 TO JCAP, C INCLUSIVE C C LOWER TRIANGULAR MATRIX OF COMPLEX NUMBERS: C C L --> C C X C N X X C X X X C ? X X X X C V X X X X X C X X X X X X C C ORDER OF THE MATRIX ELEMENTS IN MEMORY: C C (0,0), (1,0), (2,0), ..., (JCAP,0), (1,1), (2,1), (3,1), ... C INTEGER OFFSET OFFSET(N,L) = (JCAP+1)*(JCAP+2) - (JCAP-L+1)*(JCAP-L+2) + 2*(N-L) C C --- C C TERM(1,N,L,K) AND TERM(2,N,L,K) ARE C THE REAL AND IMAGINARY PART, RESP., C OF EXP((0,1)*L*PHI) TIMES THE (N,L) TERM C IN THE EXPANSION IN SPHERICAL C HARMONICS OF THE FIELD AT LEVEL K, C WHERE PHI IS THE AZIMUTHAL ANGLE C C TERM(I,N,L,K) = DI(OFFSET(N,L)+I,K) C C DATA IFIRST/0/ IF(IFIRST.NE.0) GO TO 999 DO L = 0, JCAP DO N = L, JCAP TEMP=((N*N-L*L)/(4.*N*N-1.)) IF(N.EQ.0) TEMP=0. TEMP=SQRT(TEMP) EPS(OFFSET(N,L)+1)=TEMP EPS(OFFSET(N,L)+2)=TEMP END DO N=JCAP+1 TEMP=((N*N-L*L)/(4.*N*N-1.)) TOPEPS(L)=SQRT(TEMP) END DO C IFIRST=1 999 CONTINUE CMIC$ DO ALL CMIC$1 AUTOSCOPE DO 1000 K = 1, 28 C THE CASE N=L DO L = 1, JCAP-1 RL=L N = L RN=N C DO K = 1, 28 ZE(OFFSET(N,L)+1,K)=-RL*VLN(OFFSET(N,L)+2,K) 1 -RN*EPS(OFFSET(N+1,L)+1)*ULN(OFFSET(N+1,L)+1,K) C ZE(OFFSET(N,L)+2,K)= RL*VLN(OFFSET(N,L)+1,K) 1 -RN*EPS(OFFSET(N+1,L)+2)*ULN(OFFSET(N+1,L)+2,K) C DI(OFFSET(N,L)+1,K)=-RL*ULN(OFFSET(N,L)+2,K) 1 +RN*EPS(OFFSET(N+1,L)+1)*VLN(OFFSET(N+1,L)+1,K) C DI(OFFSET(N,L)+2,K)= RL*ULN(OFFSET(N,L)+1,K) 1 +RN*EPS(OFFSET(N+1,L)+2)*VLN(OFFSET(N+1,L)+2,K) C C END DO END DO CCCCCCC C DO K=1, 28 ZE(1,K)=0. ZE(2,K)=0. DI(1,K)=0. DI(2,K)=0. C ENDDO DO L = 0, JCAP RL=L DO N = L+1, JCAP-1 RN=N C DO K = 1, 28 ZE(OFFSET(N,L)+1,K)=-RL*VLN(OFFSET(N,L)+2,K) 1 -RN*EPS(OFFSET(N+1,L)+1)*ULN(OFFSET(N+1,L)+1,K) 2 +(RN+1.)*EPS(OFFSET(N,L)+1)*ULN(OFFSET(N-1,L)+1,K) C ZE(OFFSET(N,L)+2,K)= RL*VLN(OFFSET(N,L)+1,K) 1 -RN*EPS(OFFSET(N+1,L)+2)*ULN(OFFSET(N+1,L)+2,K) 2 +(RN+1.)*EPS(OFFSET(N,L)+2)*ULN(OFFSET(N-1,L)+2,K) C DI(OFFSET(N,L)+1,K)=-RL*ULN(OFFSET(N,L)+2,K) 1 +RN*EPS(OFFSET(N+1,L)+1)*VLN(OFFSET(N+1,L)+1,K) 2 -(RN+1.)*EPS(OFFSET(N,L)+1)*VLN(OFFSET(N-1,L)+1,K) C DI(OFFSET(N,L)+2,K)= RL*ULN(OFFSET(N,L)+1,K) 1 +RN*EPS(OFFSET(N+1,L)+2)*VLN(OFFSET(N+1,L)+2,K) 2 -(RN+1.)*EPS(OFFSET(N,L)+2)*VLN(OFFSET(N-1,L)+2,K) C C END DO END DO END DO C DO TOP ROW INVOLVING U,V AT N=JCAP+1 CCCCCCC N = JCAP RN=N DO L = 0, JCAP RL=L C DO K = 1, 28 ZE(OFFSET(N,L)+1,K)=-RL*VLN(OFFSET(N,L)+2,K) 2 +(RN+1.)*EPS(OFFSET(N,L)+1)*ULN(OFFSET(N-1,L)+1,K) C ZE(OFFSET(N,L)+2,K)= RL*VLN(OFFSET(N,L)+1,K) 2 +(RN+1.)*EPS(OFFSET(N,L)+2)*ULN(OFFSET(N-1,L)+2,K) C DI(OFFSET(N,L)+1,K)=-RL*ULN(OFFSET(N,L)+2,K) 2 -(RN+1.)*EPS(OFFSET(N,L)+1)*VLN(OFFSET(N-1,L)+1,K) C DI(OFFSET(N,L)+2,K)= RL*ULN(OFFSET(N,L)+1,K) 2 -(RN+1.)*EPS(OFFSET(N,L)+2)*VLN(OFFSET(N-1,L)+2,K) C C END DO END DO CCCCCCC DO L = 0, JCAP C DO K = 1, 28 ZE(OFFSET(N,L)+1,K)=ZE(OFFSET(N,L)+1,K) 1 -RN*TOPEPS(L)*TOPULN(1,L,K) C ZE(OFFSET(N,L)+2,K)=ZE(OFFSET(N,L)+2,K) 1 -RN*TOPEPS(L)*TOPULN(2,L,K) C DI(OFFSET(N,L)+1,K)=DI(OFFSET(N,L)+1,K) 1 +RN*TOPEPS(L)*TOPVLN(1,L,K) C DI(OFFSET(N,L)+2,K)=DI(OFFSET(N,L)+2,K) 1 +RN*TOPEPS(L)*TOPVLN(2,L,K) C C END DO END DO CCCCCCC C DO K = 1, 28 DO J=1, 4032 DI(J,K)=DI(J,K)/ 6.3712E+6 ZE(J,K)=ZE(J,K)/ 6.3712E+6 END DO C END DO 1000 CONTINUE RETURN END SUBROUTINE UVSUMS(FPU,FMU,FPV,FMV,TOPULN,TOPVLN,QVV,LEVS,WGT) C C THIS SR ASSUMES JCAP IS EVEN C THIS SR ASSUMES JCAP IS EVEN C THIS SR ASSUMES JCAP IS EVEN C DIMENSION FPU(2,0: 62 ,LEVS) DIMENSION FPV(2,0: 62 ,LEVS) DIMENSION FMU(2,0: 62 ,LEVS) DIMENSION FMV(2,0: 62 ,LEVS) DIMENSION TOPULN(2,0: 62 ,LEVS) DIMENSION TOPVLN(2,0: 62 ,LEVS) DIMENSION TOPPLN(0: 62 ) DIMENSION QVV( 4158 ) C C ---------------------------------------------------------------- C COMPUTE EXPANSION COEFFS. FOR TOP ROWS OF U AND V C ---------------------------------------------------------------- CC C WRITE(60,101)WGT C101 FORMAT(1H ,'WGT= ',E12.3) LEN=2* 63 J=LEN+1 DO 10 L=0, 62 TOPPLN(L) = QVV(J)*WGT J=LEN+J LEN=LEN-2 10 CONTINUE C WRITE(60,100)TOPPLN C100 FORMAT(1H ,'TOPPLN ', 63 (1X,E12.3)) CC N= 62 +1 CCCCCCCCFPUP$ CNCAL CMIC$ DO ALL CMIC$1 AUTOSCOPE C DO L = 1, 62 ,2 C C ODD WAVENUMBER DO L = MOD( 63 ,2), 62 ,2 C C COMPUTE THE EVEN (N-L) EXPANSION COEFFICIENTS FOR EACH LEVEL C ------------------------------------------------------------ C C REAL PART C DO K = 1, LEVS TOPULN(1,L,K) = TOPULN(1,L,K)+FPU(1,L,K)*TOPPLN(L) TOPVLN(1,L,K) = TOPVLN(1,L,K)+FPV(1,L,K)*TOPPLN(L) END DO C C IMAGINARY PART C DO K = 1, LEVS TOPULN(2,L,K) = TOPULN(2,L,K)+FPU(2,L,K)*TOPPLN(L) TOPVLN(2,L,K) = TOPVLN(2,L,K)+FPV(2,L,K)*TOPPLN(L) END DO END DO C CMIC$ DO ALL CMIC$1 AUTOSCOPE C C DO L = 0, 62 ,2 C ODD WAVENUMBER DO L = MOD( 62 ,2), 62 ,2 C COMPUTE THE ODD (N-L) EXPANSION COEFFICIENTS FOR EACH LEVEL C ----------------------------------------------------------- C C REAL PART C DO K = 1, LEVS TOPULN(1,L,K) = TOPULN(1,L,K)+FMU(1,L,K)*TOPPLN(L) TOPVLN(1,L,K) = TOPVLN(1,L,K)+FMV(1,L,K)*TOPPLN(L) END DO C C IMAGINARY PART C DO K = 1, LEVS TOPULN(2,L,K) = TOPULN(2,L,K)+FMU(2,L,K)*TOPPLN(L) TOPVLN(2,L,K) = TOPVLN(2,L,K)+FMV(2,L,K)*TOPPLN(L) END DO END DO C RETURN END CFPP$ NOCONCUR R SUBROUTINE GOZRIN(QLNT,QLNV,QDERT,EPSI,LAT,RCS2,WGT) CC DIMENSION QLNT( 4032 ) DIMENSION QLNV( 4158 ) DIMENSION QDERT( 4032 ) DIMENSION EPSI( 64 , 63 ) DIMENSION RCS2( 47 ) DIMENSION WGT( 47 ) CC COMMON /GOZCOM/ DXA( 4032 ),DXB( 4032 ) CC CCC PART BETWEEN GUARDS MADE INTO SR GGOZRI. CCC 7 DEC 1990 M. ROZWODOSKI CC CC COMPUTE PLN DERIVATIVES IN IBM ORDER. WCSA=RCS2(LAT)/ 6.3712E+6 CC LP0 = 0 LP1 = 2 LEN = 126 DO 640 I=1, 63 DO 620 LL=1,LEN QDERT(LL+LP0) = QLNV(LL+LP1) * DXB(LL+LP0) 620 CONTINUE LP1 = LP1 + LEN + 2 LP0 = LP0 + LEN LEN = LEN - 2 640 CONTINUE CC LEND = 4032 - 4 DO 720 LL=1,LEND QDERT(LL+2) = QDERT(LL+2) + QLNT(LL) * DXA(LL+2) 720 CONTINUE CC DO 760 LL=1, 4032 QDERT(LL) = QDERT(LL) * WCSA QLNT(LL) = QLNT(LL) * WGT(LAT) 760 CONTINUE CC RETURN END SUBROUTINE AMBMSV(KMX,SI,SL,TOV,AM,BM,SV,GV,CM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: AMBMSV COMPUTES CONSTANT MATRICES. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-06 C C ABSTRACT: COMPUTES THE 3 MATRICES AM AND BM AND SV. C THE MATRICES REPRESENT THE LINEARIZED GRAVITY WAVE TERMS C OF THE EQUATIONS INVOLVED IN THE SEMI-IMPLICIT TIME INTEGRATION. C THE MATRICES ARE DEPENDENT ONLY ON THE VERTICAL STRUCTURE. C AM IS THE DIVERGENCE EQUATION'S LINEAR DEPENDENCE ON TEMPERATURE. C BM IS THE TEMPERATURE EQUATION'S LINEAR DEPENDENCE ON DIVERGENCE. C SV IS THE CONTINUITY EQUATION'S LINEAR DEPENDENCE ON DIVERGENCE. C C PROGRAM HISTORY LOG: C 88-04-06 JOSEPH SELA C 93-02-23 MARK IREDELL COMPACT VERTICAL FORMULATION C C USAGE: CALL AMBMSV(KM,SL,TOV,AM,BM,SV) C INPUT ARGUMENT LIST: C KM - INTEGER NUMBER OF VERTICAL LEVELS. C SL - REAL (KM) SIGMA LEVEL VALUES. C TOV - REAL (KM) REFERENCE TEMPERATURES. C C OUTPUT ARGUMENT LIST: C AM - REAL (KM,KM) SUCH THAT DD(K)/DT = ... + AM(K,J)*T(J) C BM - REAL (KM,KM) SUCH THAT DT(K)/DT = ... + BM(K,J)*D(J) C SV - REAL (KM) SUCH THAT DQ/DT = ... + SV(J)*D(J) C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN. C C$$$ DIMENSION SI(KMX+1),SL(KMX),TOV(KMX) DIMENSION AM(KMX,KMX),BM(KMX,KMX),SV(KMX),GV(KMX),CM(KMX,KMX) PARAMETER(RD= 2.8705E+2 ,CP= 1.0046E+3 ,RERTH= 6.3712E+6 ) PARAMETER(ROCP=RD/CP,RAA=RD/(RERTH**2)) C LOCAL ARRAY DIMENSION CD( 28 , 28 +1),CI( 28 +1, 28 ), 1 CQ( 28 +1, 28 ),CQL( 28 , 28 ) DIMENSION RNU( 28 ),RMU( 28 ),TI(2: 28 ),DT( 28 +1, 28 ) KM=KMX CALL BNMC(KM,SI,SL,CD,CI,CQ,CQL) DO 10 J=1,KM SV(J)=CQ(KM+1,J) GV(J)=RAA*TOV(J) DT(1,J)=0. DT(KM+1,J)=0. 10 CONTINUE DO 20 K=1,KM-1 TI(K+1)=0. DEL=SI(K+1)-SI(K) RSL=LOG(SI(K+1)/SI(K))/DEL RNU(K)=(1.-RSL*SI(K))/DEL RMU(K)=(RSL*SI(K+1)-1.)/DEL 20 CONTINUE RNU(KM)=0. RMU(KM)=1./SI(KM) DO 40 K=2,KM DO 30 J=1,KM TI(K)=TI(K)+CI(K,J)*TOV(J) DT(K,J)=(1-SI(K))*CQ(KM+1,J)-CQ(K,J) 30 CONTINUE 40 CONTINUE DO 70 J=1,KM DO 50 K=1,KM AM(K,J)=-RAA*CQL(K,J) BM(K,J)=(ROCP-1)*TOV(K)*CQ(KM+1,J) & +ROCP*TOV(K)*(RNU(K)*DT(K+1,J)+RMU(K)*DT(K,J)) 50 CONTINUE BM(J,J)=BM(J,J)-TOV(J) DO 60 K=1,KM DO 60 I=2,KM BM(K,J)=BM(K,J)-CD(K,I)*TI(I)*DT(I,J) 60 CONTINUE 70 CONTINUE C$DOACROSS SHARE(KM,GV,SV,AM,BM,CM),LOCAL(J,K,I) CMIC$ DO ALL SHARED(KM,GV,SV,AM,BM,CM) PRIVATE(J,K,I) DO 100 J=1,KM DO 80 K=1,KM CM(K,J)=GV(K)*SV(J) 80 CONTINUE DO 90 K=1,KM DO 90 I=1,KM CM(K,J)=CM(K,J)+AM(K,I)*BM(I,J) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE BNMC(KMX,SI,SL,CD,CI,CQ,CQL) PARAMETER(RD= 2.8705E+2 ,CP= 1.0046E+3 ,ROCP=RD/CP) DIMENSION SI(KMX+1),SL(KMX) DIMENSION CD(KMX,KMX+1),CI(KMX+1,KMX),CQ(KMX+1,KMX),CQL(KMX,KMX) C LOCAL ARRAY DIMENSION DEL( 28 ),SLK( 28 ),ALFA(2: 28 ),BETA( 28 -1) KM=KMX DO K=1,KM DEL(K)=SI(K+1)-SI(K) SLK(K)=SL(K)**ROCP ENDDO DO K=2,KM ALFA(K)=0.5*(1.-SLK(K-1)/SLK(K))/ROCP ENDDO DO K=1,KM-1 BETA(K)=0.5*(SLK(K+1)/SLK(K)-1.)/ROCP ENDDO DO KD=1,KM DO KI=1,KM+1 CD(KD,KI)=0 ENDDO ENDDO DO KD=1,KM CD(KD,KD)=-1/DEL(KD) CD(KD,KD+1)=1/DEL(KD) ENDDO DO KI=1,KM+1 DO KD=1,KM CI(KI,KD)=0 ENDDO ENDDO DO KI=2,KM CI(KI,KI-1)=0.5 CI(KI,KI)=0.5 ENDDO DO KI=1,KM+1 DO KD=KI,KM CQ(KI,KD)=0 ENDDO DO KD=1,KI-1 CQ(KI,KD)=DEL(KD) ENDDO ENDDO CQL(1,1)=DEL(1)-BETA(1)*SI(2) DO KT=2,KM-1 CQL(1,KT)=DEL(KT)-ALFA(KT)*SI(KT)-BETA(KT)*SI(KT+1) ENDDO CQL(1,KM)=DEL(KM)-ALFA(KM)*SI(KM) DO KZ=2,KM CQL(KZ,1)=CQL(1,1)+BETA(1) DO KT=2,KZ-1 CQL(KZ,KT)=CQL(1,KT)+ALFA(KT)+BETA(KT) ENDDO CQL(KZ,KZ)=CQL(1,KZ)+ALFA(KZ) DO KT=KZ+1,KM CQL(KZ,KT)=CQL(1,KT) ENDDO ENDDO RETURN END SUBROUTINE WRTSFC(FHOUR,THOUR,IDATE,NN,SLMASK,COLRAB, 1 DUSFC,DVSFC,DTSFC,DQSFC,TSEA,SMC,STC,SHELEG, 2 SECSWR,SECLWR,DLWSFC,ULWSFC,GESHEM,BENGSH,GFLUX, 3 FLUXR,ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 4 U10,V10,T2,Q2,PSURF,ZORL,TMPMAX,TMPMIN, 5 SNOWFALL,SNOWEVAP,SNOWMELT, & RUNOFF,EP,CLDWRK,DUGWD,DVGWD,HPBL,PWAT) COMMON/COMBIT/NDEX( 4032 ),SNNP1( 4032 ) COMMON/COMBIT/LAB(4),IFIN,ICEN,IGEN,ICEN2,IENST,IENSI,RUNID,USRID CHARACTER*8 LAB PARAMETER(IPRS=1,ITEMP=11,IZNLW=33,IMERW=34,ISPHUM=51,IPWAT=54, $ IPCPR=59,ISNOWD=65,ICLDF=71,ICCLDF=72, $ ISLMSK=81,IZORL=83,IALBDO=84,ISOILM=144,ICEMSK=91, $ ILHFLX=121,ISHFLX=122,IZWS=124,IMWS=125,IGHFLX=155, $ IUSWFC=160,IDSWFC=161,IULWFC=162,IDLWFC=163, $ INSWFC=164,INLWFC=165, $ IDSWVB=166,IDSWVD=167,IDSWNB=168,IDSWND=169, $ ITMX=15,ITMN=16,IRNOF=90,IEP=145, $ ISNWFLL=64,ISNWEVP=230,ISNWMLT=229, & ICLDWK=146,IZGW=147,IMGW=148,IHPBL=221, $ IDSWF=204,IDLWF=205,IUSWF=211,IULWF=212,ICPCPR=214) PARAMETER(ISFC=1,ITOA=8,IELEV=105, $ ISGLEV=107,IDBLS=111,I2DBLS=112,ICOLMN=200, $ ILCBL=212,ILCTL=213,ILCLYR=214, $ IMCBL=222,IMCTL=223,IMCLYR=224, $ IHCBL=232,IHCTL=233,IHCLYR=234) PARAMETER(INST=10,IAVG=3,IACC=4) PARAMETER(IFHOUR=1,IFDAY=2) PARAMETER(LONB2= 384 ,LATB2= 47 ) PARAMETER(LONR2= 384 ,LATR2= 47 ) PARAMETER(LONB=LONB2/2,LATB=LATB2*2,LEN=LONB*LATB) LOGICAL LBM(LEN) C wne CHARACTER G(200+LEN*(16+1)/8) CHARACTER G(500+LEN*(16+1)/8) PARAMETER(NFLD=16) INTEGER IPUR(NFLD),ITLR(NFLD) DATA IPUR/IULWF , IUSWF , IUSWF , IDSWF , ICLDF, IPRS, $ IPRS, ITEMP , ICLDF, IPRS, IPRS, ITEMP , $ ICLDF, IPRS, IPRS, ITEMP / DATA ITLR/ITOA , ITOA , ISFC , ISFC , IHCLYR, IHCTL , $ IHCBL , IHCTL , IMCLYR, IMCTL , IMCBL , IMCTL , $ ILCLYR, ILCTL , ILCBL , ILCTL / REAL RTIMER(NFLD) INTEGER IDATE(4) DIMENSION SLMASK(LEN) DIMENSION COLRAB(LATB2) DIMENSION DUSFC(LEN) DIMENSION DVSFC(LEN) DIMENSION DTSFC(LEN) DIMENSION DQSFC(LEN) DIMENSION TSEA(LEN) DIMENSION SMC(LEN, 2 ) DIMENSION STC(LEN, 2 ) DIMENSION SHELEG(LEN) DIMENSION DLWSFC(LEN) DIMENSION ULWSFC(LEN) DIMENSION GESHEM(LEN) DIMENSION BENGSH(LEN) DIMENSION GFLUX(LEN) DIMENSION FLUXR(LONR2,LATR2,26) DIMENSION ILEFT(LONB2),IRGHT(LONB2),WGTLON(LONB2) DIMENSION INSLAT(LATB2),WGTLAT(LATB2) DIMENSION U10 (LEN) DIMENSION V10 (LEN) DIMENSION T2 (LEN) DIMENSION Q2 (LEN) DIMENSION PSURF(LEN) DIMENSION SNOWFALL(LEN) DIMENSION SNOWEVAP(LEN) DIMENSION SNOWMELT(LEN) DIMENSION ZORL (LEN) DIMENSION TMPMAX (LEN) DIMENSION TMPMIN (LEN) DIMENSION RUNOFF (LEN) DIMENSION EP (LEN) DIMENSION CLDWRK (LEN) DIMENSION DUGWD(LEN), DVGWD(LEN) DIMENSION HPBL (LEN) DIMENSION PWAT (LEN) DIMENSION FLUXF(LEN,4),WORK1(LEN),WORK2(LONB2),SLMSEP(LEN) DIMENSION WORKC(LONB2*20),IWORKC(LONB2) DIMENSION IDS(255) DIMENSION IENS(5) C REWIND NN CALL IDSDEF(1,IDS) ILPDS=28 IF(ICEN2.EQ.2) ILPDS=45 C-ADDED 2-19-98 IENST=0 IENSI=0 IENS(1)=1 IENS(2)=IENST IENS(3)=IENSI IENS(4)=1 IENS(5)=255 IYR=IDATE(4) IMO=IDATE(2) IDA=IDATE(3) IHR=IDATE(1) IFHR=NINT(FHOUR) ITHR=NINT(THOUR) IF(THOUR.GT.FHOUR) THEN RTIME=1./(3600.*(THOUR-FHOUR)) ELSE RTIME=0. ENDIF IF(SECSWR.GT.0.) THEN RTIMSW=1./SECSWR ELSE RTIMSW=1. ENDIF IF(SECLWR.GT.0.) THEN RTIMLW=1./SECLWR ELSE RTIMLW=1. ENDIF DO N=1,NFLD RTIMER(N)=RTIMSW ENDDO RTIMER(1)=RTIMLW DO N=1,LEN SLMSEP(N)=SLMASK(N) ENDDO CALL ROWSEP(SLMSEP) CL1=COLRAB(1) CC DO N=1,LEN WORK1(N)=DUSFC(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IZWS,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IZWS),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=DVSFC(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IMWS,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IMWS),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=DTSFC(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ISHFLX,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ISHFLX),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=DQSFC(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ILHFLX,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ILHFLX),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=TSEA(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ITEMP,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=SMC(N,1) LBM(N)=SLMSEP(N).EQ.1. ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 1,ISOILM,I2DBLS,0,10,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ISOILM),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=SMC(N,2) LBM(N)=SLMSEP(N).EQ.1. ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 1,ISOILM,I2DBLS,10,200,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ISOILM),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=STC(N,1) LBM(N)=SLMSEP(N).EQ.1. ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 1,ITEMP,I2DBLS,0,10,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=STC(N,2) LBM(N)=SLMSEP(N).EQ.1. ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 1,ITEMP,I2DBLS,10,200,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=SHELEG(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ISNOWD,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ISNOWD),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=DLWSFC(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IDLWF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDLWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=ULWSFC(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IULWF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IULWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC C....... FIX FLUXES FOR APPROX DIURNAL CYCLE DO 113 K=1,4 CALL GGINTF(FLUXR(1,1,K),LONR2,LATR2,LATR2, 1 WORK1,LONB2,LATB2,LATB2,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) DO N=1,LEN WORK1(N)=WORK1(N)*RTIMER(K) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IPUR(K),ITLR(K),0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPUR(K)),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) 113 CONTINUE C....INTERPOLATE CLD TOP/BOT DATA ONLY FROM THOSE POINTS W/CLDS C CARE IS TAKEN NOT TO SPREAD CLOUDS.... IW1=1 IW2=IW1+4*LONB2 IW3=IW2+4*LONB2 IW4=IW3+4*LONB2 IW5=IW4+4*LONB2 DO 813 K=5,7 DO 413 J=1,LATR2 DO 413 I=1,LONR2 IF(FLUXR(I,J,K).GT.0.) THEN FLUXR(I,J,K+3) = FLUXR(I,J,K+3) / FLUXR(I,J,K) FLUXR(I,J,K+6) = FLUXR(I,J,K+6) / FLUXR(I,J,K) FLUXR(I,J,K+9) = FLUXR(I,J,K+9) / FLUXR(I,J,K) FLUXR(I,J,K) = FLUXR(I,J,K) * RTIMSW ELSE C.... ZERO CLD TOP TEMP IF NO CLDS--SAFETY, CAUSE USE ZERO IN GGINTT FLUXR(I,J,K+9) = 0. END IF 413 CONTINUE CALL CVINTFX(FLUXR(1,1,K),FLUXR(1,1,K+3),FLUXR(1,1,K+6), 1 LONR2,LATR2,LATR2, 2 FLUXF(1,1),FLUXF(1,2),FLUXF(1,3), 3 LONB2,LATB2,LATB2, 4 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 5 WORKC(IW1),WORKC(IW2),WORKC(IW3),WORKC(IW4), 6 WORKC(IW5),IWORKC,1,1,1) C....AVERAGE CLD TOP TEMPS FROM ONLY THE CLOUD-FILLED POINTS... CALL GGAVET(FLUXR(1,1,K+9),LONR2,LATR2,LATR2, 1 FLUXF(1,4),LONB2,LATB2,LATB2, 2 ILEFT,IRGHT,INSLAT,WGTLAT, 3 WORKC(IW1),WORKC(IW2),IWORKC,1,1,1) CKAC CALL GGINTF(FLUXR(1,1,K+9),LONR2,LATR2,LATR2, CKAC 1 FLUXF(1,4),LONB2,LATB2,LATB2,1, CKAC 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) DO 513 J=1,LATR2 DO 513 I=1,LONR2 IF(FLUXR(I,J,K).GT.0.) THEN FLUXR(I,J,K) = FLUXR(I,J,K) / RTIMSW FLUXR(I,J,K+3) = FLUXR(I,J,K+3) * FLUXR(I,J,K) FLUXR(I,J,K+6) = FLUXR(I,J,K+6) * FLUXR(I,J,K) FLUXR(I,J,K+9) = FLUXR(I,J,K+9) * FLUXR(I,J,K) ELSE C.... ZERO CLD TOP TEMP IF NO CLDS--SAFETY, CAUSE USE ZERO IN GGINTT FLUXR(I,J,K+9) = 0. END IF 513 CONTINUE C K4=4+(K-5)*4 CALL ROWSEP(FLUXF(1,1)) DO N=1,LEN FLUXF(N,1)=FLUXF(N,1)*1.E2 LBM(N)=FLUXF(N,1).GT.0.5 ENDDO L=K4+1 CALL GRIBIT(FLUXF(1,1),LBM,4,LONB,LATB,16,CL1,ILPDS, & 132,ICEN,IGEN, & 0,IPUR(L),ITLR(L),0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPUR(L)),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C CALL ROWSEP(FLUXF(1,2)) DO N=1,LEN FLUXF(N,2)=FLUXF(N,2)*1.E3 ENDDO L=K4+2 CALL GRIBIT(FLUXF(1,2),LBM,4,LONB,LATB,16,CL1,ILPDS, & 132,ICEN,IGEN, & 1,IPUR(L),ITLR(L),0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPUR(L)),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C CALL ROWSEP(FLUXF(1,3)) DO N=1,LEN C FLUXF(N)(:,3)=FLUXF(N)(:,3)*1.E3 FLUXF(N,3)=FLUXF(N,3)*1.E3 ENDDO DO N=1,LEN L=K4+3 ENDDO CALL GRIBIT(FLUXF(1,3),LBM,4,LONB,LATB,16,CL1,ILPDS, & 132,ICEN,IGEN, & 1,IPUR(L),ITLR(L),0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPUR(L)),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C CALL ROWSEP(FLUXF(1,4)) L=K4+4 CALL GRIBIT(FLUXF(1,4),LBM,4,LONB,LATB,16,CL1,ILPDS, & 132,ICEN,IGEN, & 1,IPUR(L),ITLR(L),0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPUR(L)),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C 813 CONTINUE CC DO N=1,LEN WORK1(N)=GESHEM(N)*1.E3*RTIME ENDDO CALL ROWSEP(WORK1) C LBM=WORK1.GT.0. CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IPCPR,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IPCPR),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=BENGSH(N)*1.E3*RTIME ENDDO CALL ROWSEP(WORK1) C LBM=WORK1.GT.0. CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ICPCPR,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ICPCPR),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=GFLUX(N)*RTIME LBM(N)=SLMSEP(N).NE.0. ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 1,IGHFLX,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IGHFLX),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=MOD(SLMSEP(N),2.) ENDDO CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ISLMSK,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ISLMSK),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=MAX(SLMSEP(N)-1.,0.) ENDDO CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ICEMSK,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ICEMSK),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=U10(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IZNLW,IELEV,0,10,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(IZNLW),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=V10(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IMERW,IELEV,0,10,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(IMERW),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=T2(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ITEMP,IELEV,0,2,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ITEMP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=Q2(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ISPHUM,IELEV,0,2,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ISPHUM),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=PSURF(N)*1.E3 ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IPRS,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(IPRS),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC C-WAV DO N=1,LEN C-WAV WORK1(N)=ZORL(N)*1.E-2 C-WAV ENDDO C-WAV CALL ROWSEP(WORK1) C-WAV DO N=1,LEN C-WAV LBM(N)=SLMSEP(N).EQ.0. C-WAV ENDDO C-WAV CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, C-WAV& 1,IZORL,ISFC,0,0,IYR,IMO,IDA,IHR, C-WAV& IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(IZORL),IENS, C-WAV& 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) C-WAV IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=TMPMAX(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ITMX,IELEV,0,2,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ITMX),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C C RESET TMPMAX C DO N=1,LEN TMPMAX(N) = 0. ENDDO CC DO N=1,LEN WORK1(N)=TMPMIN(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ITMN,IELEV,0,2,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(ITMN),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C C RESET TMPMIN C DO N=1,LEN TMPMIN(N) = 1.E10 ENDDO CC DO N=1,LEN WORK1(N)=RUNOFF(N) * 1.E3 LBM(N)=SLMSEP(N).NE.0. ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 1,IRNOF,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IACC,0,0,ICEN2,IDS(IRNOF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=EP(N) * RTIME LBM(N)=SLMSEP(N).NE.0. ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 1,IEP,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IEP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=CLDWRK(N) * RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ICLDWK,ICOLMN,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ICLDWK),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=DUGWD(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IZGW,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IZGW),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=DVGWD(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IMGW,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IMGW),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=HPBL(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IHPBL,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(IHPBL),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO N=1,LEN WORK1(N)=PWAT(N) ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IPWAT,ICOLMN,0,0,IYR,IMO,IDA,IHR, & IFHOUR,ITHR,0,INST,0,0,ICEN2,IDS(IPWAT),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C DO N=1,LEN WORK1(N)=SNOWFALL(N)*1.E3*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,COLRAB,28,132,ICEN,IGEN, & 0,ISNWFLL,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ISNWFLL),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C DO N=1,LEN WORK1(N)=SNOWEVAP(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,COLRAB,28,132,ICEN,IGEN, & 0,ISNWEVP,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ISNWEVP),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C DO N=1,LEN WORK1(N)=SNOWMELT(N)*RTIME ENDDO CALL ROWSEP(WORK1) CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,COLRAB,28,132,ICEN,IGEN, & 0,ISNWMLT,ISFC,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ISNWMLT),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C C ALBEDO REMOVED C C CALL GGINTF(FLUXR(1,1,17),LONR2,LATR2,LATR2, C 1 WORK1,LONB2,LATB2,LATB2,1, C 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) C CONVERT TO PERCENT C DO N=1,LEN C WORK1(N)=WORK1(N)*RTIMSW * 100. C ENDDO CC C CALL ROWSEP(WORK1) C CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, C & 0,IALBDO,ISFC,0,0,IYR,IMO,IDA,IHR, C & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IALBDO),IENS, C & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) C IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C C Added 7/31/97 C CALL GGINTF(FLUXR(1,1,18), LONR2 , LATR2 , LATR2 , 1 WORK1, LONB2 , LATB2 , LATB2 ,1, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT,WORK2,1,1,1) DO N=1,LEN WORK1(N)=WORK1(N)*RTIME ENDDO CALL ROWSEP(WORK1) C LBM=WORK.NE.0. CALL GRIBIT(WORK1,LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,IDSWF,ITOA,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(IDSWF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) CC DO 1413 J=1,LATR2 DO 1413 I=1,LONR2 FLUXR(I,J,26) = FLUXR(I,J,26) * RTIMSW 1413 CONTINUE CALL CVINAMT(FLUXR(1,1,26), 1 LONR2,LATR2,LATR2, 2 FLUXF(1,1), 3 LONB2,LATB2,LATB2, 4 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 5 WORKC(IW1),WORKC(IW2), 6 WORKC(IW5),IWORKC,1,1,1) C... RESET DATA DO 1513 J=1,LATR2 DO 1513 I=1,LONR2 FLUXR(I,J,26) = FLUXR(I,J,26) / RTIMSW 1513 CONTINUE C CALL ROWSEP(FLUXF(1,1)) DO N=1,LEN FLUXF(N,1)=FLUXF(N,1)*1.E2 LBM(N)=FLUXF(N,1).GT.0. ENDDO CALL GRIBIT(FLUXF(1,1),LBM,4,LONB,LATB,16,CL1,ILPDS,132,ICEN,IGEN, & 0,ICLDF,ICOLMN,0,0,IYR,IMO,IDA,IHR, & IFHOUR,IFHR,ITHR,IAVG,0,0,ICEN2,IDS(ICLDF),IENS, & 0.,0.,0.,0.,0.,0.,0.,0.,G,LG,IERR) IF(IERR.EQ.0) CALL WRYTE(NN,LG,G) C CLOSE(NN) CC PRINT *,'GRIB FLUX FILE WRITTEN ',THOUR,IDATE,NN RETURN END SUBROUTINE CVINTFX(CVIN,CVTIN,CVBIN,IIN,JTWIDL,JIN, 1 CVOUT,CVTOUT,CVBOUT,IOUT,JPOUT,JOUT, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 3 XX,WGT,TT,BB,SUM,NN, 4 LTWIDL,LATRD1,LATINB) C-- ***************************************************************** C * CODE BILINEARLY INTERPOLATES CLD AMT BETWEEN GAUSSIAN GRIDS--* C * CLONE OF GGINTP FOR INTERPOLATION OF CONVECTIVE CLD AMT (CV).* C * SPECIAL INTERP PROCEDURE FOR TOPS(CVT) AND BOTS(CVB)... * C- * J = 1 IS JUST BELO N.POLE, I = 1 IS GREENWICH (THEN GO EAST).* C * IIN,JIN ARE I,J DIMENSIONS OF INPUT GRID--IOUT,JOUT FOR OUTPUT* C * JIN2,JOUT2=JIN/2,JOUT/2 * C * --K.CAMPANA - JUNE 1988 * C-- ***************************************************************** DIMENSION CVIN(IIN,JTWIDL),CVTIN(IIN,JTWIDL),CVBIN(IIN,JTWIDL) DIMENSION CVOUT(IOUT,JPOUT) DIMENSION CVTOUT(IOUT,JPOUT),CVBOUT(IOUT,JPOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION INSLAT(JOUT),WGTLAT(JOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4),TT(IOUT,4),BB(IOUT,4),SUM(IOUT,4) DIMENSION NN(IOUT) III = IIN JBB = JTWIDL JJJ = JIN IIIOUT = IOUT LBB = LTWIDL LR1 = LATRD1 DO 50 LATOUT=1,JPOUT LAT=LATOUT+LATINB-1 CCC PRINT 100,LAT,XLAT C===> IF OUTPUT LAT IS POLEWARD OF INPUT LAT=1 ,THEN SIMPL AVERAGE C (SMALL REGION AND CLD AMT WOULDN T EXTRAPOLATE WELL) CALL CINTPX(III,JBB,JJJ,IIIOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT(LAT),WGTLAT(LAT), 2 CVIN,CVTIN,CVBIN,CVOUT(1,LATOUT), 3 CVTOUT(1,LATOUT),CVBOUT(1,LATOUT), 3 XX,WGT,TT,BB,SUM,NN,LBB,LR1) 50 CONTINUE CK100 FORMAT(1H ,' ROW =',I5,' LAT =',E15.5) RETURN END SUBROUTINE CINTPX(IIN,JTWIDL,JIN,IOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 2 CV,CVT,CVB,CAMT,CTOP,CBOT, 3 XX,WGT,TT,BB,SUM,NN,LTWIDL,LATRD1) DIMENSION CV(IIN,JTWIDL),CVT(IIN,JTWIDL),CVB(IIN,JTWIDL) DIMENSION CAMT(IOUT),CTOP(IOUT),CBOT(IOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4),TT(IOUT,4),BB(IOUT,4),SUM(IOUT,4) DIMENSION NN(IOUT) C SIMPL LINEAR INTERPOLATION OF CLDAMT, UNLESS ONLY 1,2 OF THE C SURROUNDING PTS HAS CV. THEN,IF OUTPUT GRIDPT NOT CLOSE ENUF C DO NOT INTERPOLATE TO IT(PREVENTS SPREADING OF CV CLDS).. C FOR 1 PT CONVECTION-INTRP WGT GE (.7)**2 ... C FOR 2 PT CONVECTION-SUM OF INTRP WGT GE .45... C .45 USED RATHER THAN .5 TO GIVE BETTER RESULT FOR C DIAGONALLY OPPOSED PTS... C===> FOR TOPS(CVT) AND BOTS(CVB) JUST TAKE AVERAGE OF SURROUNDING C NON-ZERO CV POINTS..... C NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) C--- NHSH = 1,-1 FOR NORTHERN,SOUTHERN HEMISPHERE C HERE INSTEAD OF AN EXTRAPOLATION,JUST DO A SIMPLE MEAN.... C IF (INSLAT.LT.0) GO TO 600 C INTH = MOD(LTWIDL + INSLAT - LATRD1 - 1,JTWIDL) + 1 INTH = MOD(LTWIDL + INSLAT + JTWIDL - LATRD1 - 1,JTWIDL) + 1 INTH1 = MOD(INTH,JTWIDL) + 1 IF (INSLAT.EQ.JIN) GO TO 105 DO 100 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),INTH) XX(I,2) = CV(ILEFT(I),INTH1) XX(I,3) = CV(IRGHT(I),INTH) XX(I,4) = CV(IRGHT(I),INTH1) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT TT(I,1) = CVT(ILEFT(I),INTH) TT(I,2) = CVT(ILEFT(I),INTH1) TT(I,3) = CVT(IRGHT(I),INTH) TT(I,4) = CVT(IRGHT(I),INTH1) BB(I,1) = CVB(ILEFT(I),INTH) BB(I,2) = CVB(ILEFT(I),INTH1) BB(I,3) = CVB(IRGHT(I),INTH) BB(I,4) = CVB(IRGHT(I),INTH1) 100 CONTINUE GO TO 130 105 DO 110 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),INTH) XX(I,3) = CV(IRGHT(I),INTH) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT TT(I,1) = CVT(ILEFT(I),INTH) TT(I,3) = CVT(IRGHT(I),INTH) BB(I,1) = CVB(ILEFT(I),INTH) BB(I,3) = CVB(IRGHT(I),INTH) 110 CONTINUE IOUT2 = IOUT / 2 DO 120 I=1,IOUT2 XX(I,2) = CV(ILEFT(I+IOUT2),INTH) XX(I+IOUT2,2) = CV(ILEFT(I),INTH) XX(I,4) = CV(IRGHT(I+IOUT2),INTH) XX(I+IOUT2,4) = CV(IRGHT(I),INTH) BB(I,2) = CVB(ILEFT(I+IOUT2),INTH) BB(I+IOUT2,2) = CVB(ILEFT(I),INTH) BB(I,4) = CVB(IRGHT(I+IOUT2),INTH) BB(I+IOUT2,4) = CVB(IRGHT(I),INTH) TT(I,2) = CVT(ILEFT(I+IOUT2),INTH) TT(I+IOUT2,2) = CVT(ILEFT(I),INTH) TT(I,4) = CVT(IRGHT(I+IOUT2),INTH) TT(I+IOUT2,4) = CVT(IRGHT(I),INTH) 120 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) CKAC NN(1;IOUT) = 0 CKAC SUM(1,1;IOUT*4) = 0. E 0 130 DO 10 I=1,IOUT NN(I) = 0 10 CONTINUE DO 12 J=1,4 DO 12 I=1,IOUT SUM(I,J) = 0. E 0 12 CONTINUE DO 150 KPT=1,4 CKAC WHERE (XX(1,KPT;IOUT).GT.0. E 0) CKAC NN(1;IOUT) = NN(1;IOUT) + 1 CKAC SUM(1,1;IOUT) = SUM(1,1;IOUT) + WGT(1,KPT;IOUT) CKAC SUM(1,2;IOUT) = SUM(1,2;IOUT) + TT(1,KPT;IOUT) CKAC SUM(1,3;IOUT) = SUM(1,3;IOUT) + BB(1,KPT;IOUT) CKAC ENDWHERE CKAC SUM(1,4;IOUT) = SUM(1,4;IOUT) + WGT(1,KPT;IOUT) * CKAC 1 XX(1,KPT;IOUT) DO 14 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) SUM(I,2) = SUM(I,2) + TT(I,KPT) SUM(I,3) = SUM(I,3) + BB(I,KPT) ENDIF 14 CONTINUE DO 15 I=1,IOUT SUM(I,4) = SUM(I,4) + WGT(I,KPT) * XX(I,KPT) 15 CONTINUE 150 CONTINUE CKAC WHERE((NN(1;IOUT).EQ.1 .AND. SUM(1,1;IOUT).GT.0.49 E 0) .OR. CKAC 1 (NN(1;IOUT).EQ.2 .AND. SUM(1,1;IOUT).GE.0.45 E 0) .OR. CKAC 2 NN(1;IOUT).GE.3) CKAC CTOP(1;IOUT) = VAINT(SUM(1,2;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CTOP(1;IOUT)) CKAC CBOT(1;IOUT) = VAINT(SUM(1,3;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CBOT(1;IOUT)) CKAC CAMT(1;IOUT) = SUM(1,4;IOUT) CKAC OTHERWISE CKAC CTOP(1;IOUT) = 0. E 0 CKAC CBOT(1;IOUT) = 100. E 0 CKAC CAMT(1;IOUT) = 0. E 0 CKAC ENDWHERE DO 16 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.49 E 0) GO TO 17 IF (NN(I).EQ.2.AND.SUM(I,1).GE.0.45 E 0) GO TO 17 IF (NN(I).GE.3) GO TO 17 CTOP(I) = 0. E 0 CBOT(I) = 100. E 0 CAMT(I) = 0. E 0 GO TO 18 17 CONTINUE CTOP(I) = SUM(I,2)/NN(I) CBOT(I) = SUM(I,3)/NN(I) CAMT(I) = SUM(I,4) 18 CONTINUE 16 CONTINUE RETURN C--- POLAR REGION-NO EXTRAPOLATION 600 CONTINUE JA = IABS(INSLAT) DO 200 I=1,IOUT C---- GET LEFT POINT ON NEAREST LATITUDE XX(I,1) = CV(ILEFT(I),JA) XX(I,2) = CV(IRGHT(I),JA) WGT(I,1) = 1. E 0-WGTLON(I) WGT(I,2) = WGTLON(I) TT(I,1) = CVT(ILEFT(I),JA) TT(I,2) = CVT(IRGHT(I),JA) BB(I,1) = CVB(ILEFT(I),JA) BB(I,2) = CVB(IRGHT(I),JA) 200 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) CKAC NN(1;IOUT) = 0 CKAC SUM(1,1;IOUT*4) = 0. E 0 DO 20 I=1,IOUT NN(I) = 0 20 CONTINUE DO 22 J=1,4 DO 22 I=1,IOUT SUM(I,J) = 0. E 0 22 CONTINUE DO 202 KPT=1,2 CKAC WHERE (XX(1,KPT;IOUT).GT.0. E 0) CKAC NN(1;IOUT) = NN(1;IOUT) + 1 CKAC SUM(1,1;IOUT) = SUM(1,1;IOUT) + WGT(1,KPT;IOUT) CKAC SUM(1,2;IOUT) = SUM(1,2;IOUT) + TT(1,KPT;IOUT) CKAC SUM(1,3;IOUT) = SUM(1,3;IOUT) + BB(1,KPT;IOUT) CKAC ENDWHERE CKAC SUM(1,4;IOUT) = SUM(1,4;IOUT) + WGT(1,KPT;IOUT) * CKAC 1 XX(1,KPT;IOUT) DO 24 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) SUM(I,2) = SUM(I,2) + TT(I,KPT) SUM(I,3) = SUM(I,3) + BB(I,KPT) ENDIF 24 CONTINUE DO 25 I=1,IOUT SUM(I,4) = SUM(I,4) + WGT(I,KPT) * XX(I,KPT) 25 CONTINUE 202 CONTINUE CKAC WHERE((NN(1;IOUT).EQ.1 .AND. SUM(1,1;IOUT).GT.0.7 E 0) .OR. CKAC 1 NN(1;IOUT).EQ.2) CKAC CTOP(1;IOUT) = VAINT(SUM(1,2;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CTOP(1;IOUT)) CKAC CBOT(1;IOUT) = VAINT(SUM(1,3;IOUT)/NN(1;IOUT)+0.5 E 0; CKAC 1 CBOT(1;IOUT)) CKAC CAMT(1;IOUT) = SUM(1,4;IOUT) CKAC OTHERWISE CKAC CTOP(1;IOUT) = 0. E 0 CKAC CBOT(1;IOUT) = 100. E 0 CKAC CAMT(1;IOUT) = 0. E 0 CKAC ENDWHERE DO 26 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.7 E 0) GO TO 27 IF (NN(I).EQ.2) GO TO 27 CTOP(I) = 0. E 0 CBOT(I) = 100. E 0 CAMT(I) = 0. E 0 GO TO 28 27 CONTINUE CTOP(I) = SUM(I,2)/NN(I) CBOT(I) = SUM(I,3)/NN(I) CAMT(I) = SUM(I,4) 28 CONTINUE 26 CONTINUE RETURN END SUBROUTINE CVINAMT(CVIN, IIN,JTWIDL,JIN, 1 CVOUT, IOUT,JPOUT,JOUT, 2 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 3 XX,WGT, SUM,NN, 4 LTWIDL,LATRD1,LATINB) C-- ***************************************************************** C * CODE BILINEARLY INTERPOLATES CLD AMT BETWEEN GAUSSIAN GRIDS--* C * CLONE OF CVINTFX WITHOUT THE CLOUD TOP/BASE INTERPOLATION * C- * J = 1 IS JUST BELO N.POLE, I = 1 IS GREENWICH (THEN GO EAST).* C * IIN,JIN ARE I,J DIMENSIONS OF INPUT GRID--IOUT,JOUT FOR OUTPUT* C * JIN2,JOUT2=JIN/2,JOUT/2 * C * CAMPANA+KATZ+CAMPANA(AGAIN) NOV94 * C-- ***************************************************************** DIMENSION CVIN(IIN,JTWIDL) DIMENSION CVOUT(IOUT,JPOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION INSLAT(JOUT),WGTLAT(JOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4), SUM(IOUT,4) DIMENSION NN(IOUT) III = IIN JBB = JTWIDL JJJ = JIN IIIOUT = IOUT LBB = LTWIDL LR1 = LATRD1 DO 50 LATOUT=1,JPOUT LAT=LATOUT+LATINB-1 CCC PRINT 100,LAT,XLAT C===> IF OUTPUT LAT IS POLEWARD OF INPUT LAT=1 ,THEN SIMPL AVERAGE C (SMALL REGION AND CLD AMT WOULDN T EXTRAPOLATE WELL) CALL CINPAMT(III,JBB,JJJ,IIIOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT(LAT),WGTLAT(LAT), 2 CVIN, CVOUT(1,LATOUT), 3 XX,WGT, SUM,NN,LBB,LR1) 50 CONTINUE CK100 FORMAT(1H ,' ROW =',I5,' LAT =',E15.5) RETURN END SUBROUTINE CINPAMT(IIN,JTWIDL,JIN,IOUT, 1 ILEFT,IRGHT,WGTLON,INSLAT,WGTLAT, 2 CV, CAMT, 3 XX,WGT, SUM,NN,LTWIDL,LATRD1) DIMENSION CV(IIN,JTWIDL) DIMENSION CAMT(IOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT),WGTLON(IOUT) DIMENSION XX(IOUT,4),WGT(IOUT,4), SUM(IOUT,4) DIMENSION NN(IOUT) C.. CLONE OF CINTPX WITHOUT CLDTOP/BASE INTERPOLATION..... C SIMPL LINEAR INTERPOLATION OF CLDAMT, UNLESS ONLY 1,2 OF THE C SURROUNDING PTS HAS CV. THEN,IF OUTPUT GRIDPT NOT CLOSE ENUF C DO NOT INTERPOLATE TO IT(PREVENTS SPREADING OF CLDS).. C FOR 1 PT CONVECTION-INTRP WGT GE (.7)**2 ... C FOR 2 PT CONVECTION-SUM OF INTRP WGT GE .45... C .45 USED RATHER THAN .5 TO GIVE BETTER RESULT FOR C DIAGONALLY OPPOSED PTS... C NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) C--- NHSH = 1,-1 FOR NORTHERN,SOUTHERN HEMISPHERE C HERE INSTEAD OF AN EXTRAPOLATION,JUST DO A SIMPLE MEAN.... C IF (INSLAT.LT.0) GO TO 600 C INTH = MOD(LTWIDL + INSLAT - LATRD1 - 1,JTWIDL) + 1 INTH = MOD(LTWIDL + INSLAT + JTWIDL - LATRD1 - 1,JTWIDL) + 1 INTH1 = MOD(INTH,JTWIDL) + 1 IF (INSLAT.EQ.JIN) GO TO 105 DO 100 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),INTH) XX(I,2) = CV(ILEFT(I),INTH1) XX(I,3) = CV(IRGHT(I),INTH) XX(I,4) = CV(IRGHT(I),INTH1) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT 100 CONTINUE GO TO 130 105 DO 110 I=1,IOUT C---- NORMALIZED DISTANCE FROM UPPER LAT TO GAUSSIAN LAT XX(I,1) = CV(ILEFT(I),INTH) XX(I,3) = CV(IRGHT(I),INTH) WGT(I,1) = (1. E 0-WGTLON(I))*(1. E 0-WGTLAT) WGT(I,2) = (1. E 0-WGTLON(I))*WGTLAT WGT(I,3) = WGTLON(I)*(1. E 0-WGTLAT) WGT(I,4) = WGTLON(I)*WGTLAT 110 CONTINUE IOUT2 = IOUT / 2 DO 120 I=1,IOUT2 XX(I,2) = CV(ILEFT(I+IOUT2),INTH) XX(I+IOUT2,2) = CV(ILEFT(I),INTH) XX(I,4) = CV(IRGHT(I+IOUT2),INTH) XX(I+IOUT2,4) = CV(IRGHT(I),INTH) 120 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) 130 DO 10 I=1,IOUT NN(I) = 0 10 CONTINUE DO 12 J=1,4 DO 12 I=1,IOUT SUM(I,J) = 0. E 0 12 CONTINUE DO 150 KPT=1,4 DO 14 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) ENDIF 14 CONTINUE DO 15 I=1,IOUT SUM(I,4) = SUM(I,4) + WGT(I,KPT) * XX(I,KPT) 15 CONTINUE 150 CONTINUE DO 16 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.49 E 0) GO TO 17 IF (NN(I).EQ.2.AND.SUM(I,1).GE.0.45 E 0) GO TO 17 IF (NN(I).GE.3) GO TO 17 CAMT(I) = 0. E 0 GO TO 18 17 CONTINUE CAMT(I) = SUM(I,4) 18 CONTINUE 16 CONTINUE RETURN C--- POLAR REGION-NO EXTRAPOLATION 600 CONTINUE JA = IABS(INSLAT) DO 200 I=1,IOUT C---- GET LEFT POINT ON NEAREST LATITUDE XX(I,1) = CV(ILEFT(I),JA) XX(I,2) = CV(IRGHT(I),JA) WGT(I,1) = 1. E 0-WGTLON(I) WGT(I,2) = WGTLON(I) 200 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) DO 20 I=1,IOUT NN(I) = 0 20 CONTINUE DO 22 J=1,4 DO 22 I=1,IOUT SUM(I,J) = 0. E 0 22 CONTINUE DO 202 KPT=1,2 DO 24 I=1,IOUT IF (XX(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I,1) = SUM(I,1) + WGT(I,KPT) ENDIF 24 CONTINUE DO 25 I=1,IOUT SUM(I,4) = SUM(I,4) + WGT(I,KPT) * XX(I,KPT) 25 CONTINUE 202 CONTINUE DO 26 I=1,IOUT IF (NN(I).EQ.1.AND.SUM(I,1).GT.0.7 E 0) GO TO 27 IF (NN(I).EQ.2) GO TO 27 CAMT(I) = 0. E 0 GO TO 28 27 CONTINUE CAMT(I) = SUM(I,4) 28 CONTINUE 26 CONTINUE RETURN END SUBROUTINE GGAVET(CTTIN,IIN,JTWIDL,JIN,CTTOUT,IOUT,JPOUT,JOUT, 1 ILEFT,IRGHT,INSLAT,WGTLAT, 2 TT,SUM,NN,LTWIDL,LATRD1,LATINB) C-- ***************************************************************** C * PUT CLOUD TOP TEMPERATURE ONTO FCST MODEL GRID...... * C * ONLY AVERAGE THOSE POINTS WHICH HAVE CLD (IE TEMP NONZERO) * C- * J = 1 IS JUST BELO N.POLE, I = 1 IS GREENWICH (THEN GO EAST).* C * IIN,JIN ARE I,J DIMENSIONS OF INPUT GRID--IOUT,JOUT FOR OUTPUT* C * JIN2,JOUT2=JIN/2,JOUT/2 * C * --K.CAMPANA - AUGUST 91 * C-- ***************************************************************** DIMENSION CTTIN(IIN,JTWIDL) DIMENSION CTTOUT(IOUT,JPOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT) DIMENSION INSLAT(JOUT),WGTLAT(JOUT) DIMENSION TT(IOUT,4),SUM(IOUT) DIMENSION NN(IOUT) III = IIN JBB = JTWIDL JJJ = JIN IIIOUT = IOUT LBB = LTWIDL LR1 = LATRD1 DO 50 LATOUT=1,JPOUT LAT=LATOUT+LATINB-1 CCC PRINT 100,LAT,XLAT C===> IF OUTPUT LAT IS POLEWARD OF INPUT LAT=1 ,THEN SIMPL AVERAGE C (SMALL REGION AND CLD AMT WOULDN T EXTRAPOLATE WELL) CALL GINTP(III,JBB,JJJ,IIIOUT, 1 ILEFT,IRGHT,INSLAT(LAT),WGTLAT(LAT), 2 CTTIN,CTTOUT(1,LATOUT),TT,SUM,NN,LBB,LR1) 50 CONTINUE CK100 FORMAT(1H ,' ROW =',I5,' LAT =',E15.5) RETURN END SUBROUTINE GINTP(IIN,JTWIDL,JIN,IOUT, 1 ILEFT,IRGHT,INSLAT,WGTLAT, 2 CTT,CLDT,TT,SUM,NN,LTWIDL,LATRD1) DIMENSION CTT(IIN,JTWIDL) DIMENSION CLDT(IOUT) DIMENSION ILEFT(IOUT),IRGHT(IOUT) DIMENSION TT(IOUT,4),SUM(IOUT) DIMENSION NN(IOUT) C.... FOR TOP TEMP JUST TAKE AVERAGE OF SURROUNDING C.. NON-ZERO POINTS (THESE ARE THE CLOUD-FILLED ONES).... C.. NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) IF (INSLAT.LT.0) GO TO 600 C INTH = MOD(LTWIDL + INSLAT - LATRD1 - 1,JTWIDL) + 1 INTH = MOD(LTWIDL + INSLAT + JTWIDL - LATRD1 - 1,JTWIDL) + 1 INTH1 = MOD(INTH,JTWIDL) + 1 IF (INSLAT.EQ.JIN) GO TO 105 DO 100 I=1,IOUT TT(I,1) = CTT(ILEFT(I),INTH) TT(I,2) = CTT(ILEFT(I),INTH1) TT(I,3) = CTT(IRGHT(I),INTH) TT(I,4) = CTT(IRGHT(I),INTH1) 100 CONTINUE GO TO 130 105 DO 110 I=1,IOUT TT(I,1) = CTT(ILEFT(I),INTH) TT(I,3) = CTT(IRGHT(I),INTH) 110 CONTINUE IOUT2 = IOUT / 2 DO 120 I=1,IOUT2 TT(I,2) = CTT(ILEFT(I+IOUT2),INTH) TT(I+IOUT2,2) = CTT(ILEFT(I),INTH) TT(I,4) = CTT(IRGHT(I+IOUT2),INTH) TT(I+IOUT2,4) = CTT(IRGHT(I),INTH) 120 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) 130 DO 10 I=1,IOUT NN(I) = 0 10 CONTINUE DO 12 I=1,IOUT SUM(I) = 0. E 0 12 CONTINUE DO 150 KPT=1,4 DO 14 I=1,IOUT IF (TT(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I) = SUM(I) + TT(I,KPT) ENDIF 14 CONTINUE 150 CONTINUE DO 16 I=1,IOUT IF (NN(I).LT.1) THEN CLDT(I) = 0. E 0 ELSE CLDT(I) = SUM(I) / NN(I) END IF 16 CONTINUE RETURN C--- POLAR REGION 600 CONTINUE JA = IABS(INSLAT) DO 200 I=1,IOUT TT(I,1) = CTT(ILEFT(I),JA) TT(I,2) = CTT(IRGHT(I),JA) 200 CONTINUE C--- NN WILL BE NUMBER OF SURROUNDING PTS WITH CLD (GT ZERO) DO 20 I=1,IOUT NN(I) = 0 20 CONTINUE DO 22 I=1,IOUT SUM(I) = 0. E 0 22 CONTINUE DO 202 KPT=1,2 DO 24 I=1,IOUT IF (TT(I,KPT).GT.0. E 0) THEN NN(I) = NN(I) + 1 SUM(I) = SUM(I) + TT(I,KPT) ENDIF 24 CONTINUE 202 CONTINUE DO 26 I=1,IOUT IF (NN(I).LT.1) THEN CLDT(I) = 0. E 0 ELSE CLDT(I) = SUM(I) / NN(I) END IF 26 CONTINUE RETURN END C----------------------------------------------------------------------- SUBROUTINE IDSDEF(IPTV,IDS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IDSDEF SETS DEFAULT DECIMAL SCALINGS C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 C C ABSTRACT: SETS DECIMAL SCALINGS DEFAULTS FOR VARIOUS PARAMETERS. C A DECIMAL SCALING OF -3 MEANS DATA IS PACKED IN KILO-SI UNITS. C C PROGRAM HISTORY LOG: C 92-10-31 IREDELL C C USAGE: CALL IDSDEF(IPTV,IDS) C INPUT ARGUMENTS: C IPTV PARAMTER TABLE VERSION (ONLY 1 OR 2 IS RECOGNIZED) C OUTPUT ARGUMENTS: C IDS INTEGER (255) DECIMAL SCALINGS C (UNKNOWN DECIMAL SCALINGS WILL NOT BE SET) C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C C$$$ DIMENSION IDS(255) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IPTV.EQ.1.OR.IPTV.EQ.2.or.IPTV.eq.132) THEN IDS(001)=0 ! PRESSURE (PA) IDS(002)=0 ! SEA-LEVEL PRESSURE (PA) IDS(003)=4 ! PRESSURE TENDENCY (PA/S) ! ! IDS(006)=0 ! GEOPOTENTIAL (M2/S2) IDS(007)=1 ! GEOPOTENTIAL HEIGHT (M) IDS(008)=1 ! GEOMETRIC HEIGHT (M) IDS(009)=1 ! STANDARD DEVIATION OF HEIGHT (M) ! IDS(011)=2 ! TEMPERATURE (K) IDS(012)=2 ! VIRTUAL TEMPERATURE (K) IDS(013)=2 ! POTENTIAL TEMPERATURE (K) IDS(014)=2 ! PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (K) IDS(015)=2 ! MAXIMUM TEMPERATURE (K) IDS(016)=2 ! MINIMUM TEMPERATURE (K) IDS(017)=2 ! DEWPOINT TEMPERATURE (K) IDS(018)=2 ! DEWPOINT DEPRESSION (K) IDS(019)=5 ! TEMPERATURE LAPSE RATE (K/M) IDS(020)=0 ! VISIBILITY (M) ! RADAR SPECTRA 1 () ! RADAR SPECTRA 2 () ! RADAR SPECTRA 3 () ! IDS(025)=2 ! TEMPERATURE ANOMALY (K) IDS(026)=0 ! PRESSURE ANOMALY (PA) IDS(027)=1 ! GEOPOTENTIAL HEIGHT ANOMALY (M) ! WAVE SPECTRA 1 () ! WAVE SPECTRA 2 () ! WAVE SPECTRA 3 () IDS(031)=1 ! WIND DIRECTION (DEGREES) IDS(032)=2 ! WIND SPEED (M/S) IDS(033)=2 ! ZONAL WIND (M/S) IDS(034)=2 ! MERIDIONAL WIND (M/S) IDS(035)=-4 ! STREAMFUNCTION (M2/S) IDS(036)=-4 ! VELOCITY POTENTIAL (M2/S) IDS(037)=0 ! MONTGOMERY STREAM FUNCTION (M2/S2) IDS(038)=9 ! SIGMA VERTICAL VELOCITY (1/S) IDS(039)=4 ! PRESSURE VERTICAL VELOCITY (PA/S) IDS(040)=5 ! GEOMETRIC VERTICAL VELOCITY (M/S) IDS(041)=7 ! ABSOLUTE VORTICITY (1/S) IDS(042)=7 ! ABSOLUTE DIVERGENCE (1/S) IDS(043)=7 ! RELATIVE VORTICITY (1/S) IDS(044)=7 ! RELATIVE DIVERGENCE (1/S) IDS(045)=5 ! VERTICAL U SHEAR (1/S) IDS(046)=5 ! VERTICAL V SHEAR (1/S) IDS(047)=0 ! DIRECTION OF CURRENT (DEGREES) ! SPEED OF CURRENT (M/S) ! U OF CURRENT (M/S) ! V OF CURRENT (M/S) IDS(051)=6 ! SPECIFIC HUMIDITY (KG/KG) IDS(052)=1 ! RELATIVE HUMIDITY (PERCENT) IDS(053)=6 ! HUMIDITY MIXING RATIO (KG/KG) IDS(054)=2 ! PRECIPITABLE WATER (KG/M2) IDS(055)=0 ! VAPOR PRESSURE (PA) IDS(056)=0 ! SATURATION DEFICIT (PA) IDS(057)=2 ! EVAPORATION (KG/M2) IDS(058)=2 ! CLOUD ICE (KG/M2) IDS(059)=7 ! PRECIPITATION RATE (KG/M2/S) IDS(060)=0 ! THUNDERSTORM PROBABILITY (PERCENT) IDS(061)=2 ! TOTAL PRECIPITATION (KG/M2) IDS(062)=2 ! LARGE-SCALE PRECIPITATION (KG/M2) IDS(063)=2 ! CONVECTIVE PRECIPITATION (KG/M2) IDS(064)=7 ! WATER EQUIVALENT SNOWFALL RATE (KG/M2/S) IDS(065)=1 ! WATER EQUIVALENT OF SNOW DEPTH (KG/M2) IDS(066)=3 ! SNOW DEPTH (M) ! MIXED-LAYER DEPTH (M) ! TRANSIENT THERMOCLINE DEPTH (M) ! MAIN THERMOCLINE DEPTH (M) ! MAIN THERMOCLINE ANOMALY (M) IDS(071)=1 ! TOTAL CLOUD COVER (PERCENT) IDS(072)=1 ! CONVECTIVE CLOUD COVER (PERCENT) IDS(073)=1 ! LOW CLOUD COVER (PERCENT) IDS(074)=1 ! MIDDLE CLOUD COVER (PERCENT) IDS(075)=1 ! HIGH CLOUD COVER (PERCENT) IDS(076)=2 ! CLOUD WATER (KG/M2) ! IDS(078)=2 ! CONVECTIVE SNOW (KG/M2) IDS(079)=2 ! LARGE SCALE SNOW (KG/M2) IDS(080)=2 ! WATER TEMPERATURE (K) IDS(081)=0 ! SEA-LAND MASK () ! DEVIATION OF SEA LEVEL FROM MEAN (M) IDS(083)=6 ! ROUGHNESS (M) IDS(084)=2 ! ALBEDO (PERCENT) IDS(085)=2 ! SOIL TEMPERATURE (K) IDS(086)=1 ! SOIL WETNESS (KG/M2) IDS(087)=1 ! VEGETATION (PERCENT) ! SALINITY (KG/KG) IDS(089)=5 ! DENSITY (KG/M3) IDS(090)=2 ! RUNOFF (KG/M2) IDS(091)=1 ! ICE CONCENTRATION () ! ICE THICKNESS (M) IDS(093)=0 ! DIRECTION OF ICE DRIFT (DEGREES) ! SPEED OF ICE DRIFT (M/S) ! U OF ICE DRIFT (M/S) ! V OF ICE DRIFT (M/S) ! ICE GROWTH (M) ! ICE DIVERGENCE (1/S) IDS(099)=2 ! SNOW MELT (KG/M2) ! SIG HEIGHT OF WAVES AND SWELL (M) IDS(101)=0 ! DIRECTION OF WIND WAVES (DEGREES) ! SIG HEIGHT OF WIND WAVES (M) ! MEAN PERIOD OF WIND WAVES (S) IDS(104)=0 ! DIRECTION OF SWELL WAVES (DEGREES) ! SIG HEIGHT OF SWELL WAVES (M) ! MEAN PERIOD OF SWELL WAVES (S) IDS(107)=0 ! PRIMARY WAVE DIRECTION (DEGREES) ! PRIMARY WAVE MEAN PERIOD (S) IDS(109)=0 ! SECONDARY WAVE DIRECTION (DEGREES) ! SECONDARY WAVE MEAN PERIOD (S) IDS(111)=1 ! NET SOLAR RADIATIVE FLUX AT SURFACE (W/M2) IDS(112)=1 ! NET LONGWAVE RADIATIVE FLUX AT SURFACE (W/M2) IDS(113)=1 ! NET SOLAR RADIATIVE FLUX AT TOP (W/M2) IDS(114)=1 ! NET LONGWAVE RADIATIVE FLUX AT TOP (W/M2) IDS(115)=1 ! NET LONGWAVE RADIATIVE FLUX (W/M2) IDS(116)=1 ! NET SOLAR RADIATIVE FLUX (W/M2) IDS(117)=1 ! TOTAL RADIATIVE FLUX (W/M2) ! ! ! IDS(121)=1 ! LATENT HEAT FLUX (W/M2) IDS(122)=1 ! SENSIBLE HEAT FLUX (W/M2) IDS(123)=1 ! BOUNDARY LAYER DISSIPATION (W/M2) IDS(124)=4 ! U WIND STRESS (N/M2) IDS(125)=4 ! V WIND STRESS (N/M2) ! WIND MIXING ENERGY (J) ! IMAGE DATA () IDS(128)=0 ! MEAN SEA-LEVEL PRESSURE (STDATM) (PA) IDS(129)=0 ! MEAN SEA-LEVEL PRESSURE (MAPS) (PA) IDS(130)=0 ! MEAN SEA-LEVEL PRESSURE (ETA) (PA) IDS(131)=2 ! SURFACE LIFTED INDEX (K) IDS(132)=2 ! BEST LIFTED INDEX (K) IDS(133)=2 ! K INDEX (K) IDS(134)=2 ! SWEAT INDEX (K) IDS(135)=11 ! HORIZONTAL MOISTURE DIVERGENCE (KG/KG/S) IDS(136)=5 ! SPEED SHEAR (1/S) IDS(137)=6 ! 3-HR PRESSURE TENDENCY (PA/S) IDS(138)=7 ! BRUNT-VAISALA FREQUENCY SQUARED (1/S2) IDS(139)=12 ! POTENTIAL VORTICITY (MASS-WEIGHTED) (1/S/M) IDS(140)=0 ! RAIN MASK () IDS(141)=0 ! FREEZING RAIN MASK () IDS(142)=0 ! ICE PELLETS MASK () IDS(143)=0 ! SNOW MASK () IDS(144)=4 ! VOLUMETRIC SOIL MOISTURE CONTENT (FRACTION) IDS(145)=1 ! POTENTIAL EVAPORATION RATE (W/M2) IDS(146)=1 ! CLOUD WORKFUNCTION (J/KG) IDS(147)=4 ! U GRAVITY WAVE STRESS (N/M2) IDS(148)=4 ! V GRAVITY WAVE STRESS (N/M2) IDS(149)=11 ! POTENTIAL VORTICITY (M2/S/KG) ! COVARIANCE BETWEEN V AND U (M2/S2) ! COVARIANCE BETWEEN U AND T (K*M/S) ! COVARIANCE BETWEEN V AND T (K*M/S) ! ! IDS(155)=1 ! GROUND HEAT FLUX (W/M2) IDS(156)=1 ! CONVECTIVE INHIBITION (W/M2) IDS(157)=1 ! CONVECTIVE APE (J/KG) IDS(158)=1 ! TURBULENT KE (J/KG) IDS(159)=0 ! CONDENSATION PRESSURE OF LIFTED PARCEL (PA) IDS(160)=1 ! CLEAR SKY UPWARD SOLAR FLUX (W/M2) IDS(161)=1 ! CLEAR SKY DOWNWARD SOLAR FLUX (W/M2) IDS(162)=1 ! CLEAR SKY UPWARD LONGWAVE FLUX (W/M2) IDS(163)=1 ! CLEAR SKY DOWNWARD LONGWAVE FLUX (W/M2) IDS(164)=1 ! CLOUD FORCING NET SOLAR FLUX (W/M2) IDS(165)=1 ! CLOUD FORCING NET LONGWAVE FLUX (W/M2) IDS(166)=1 ! VISIBLE BEAM DOWNWARD SOLAR FLUX (W/M2) IDS(167)=1 ! VISIBLE DIFFUSE DOWNWARD SOLAR FLUX (W/M2) IDS(168)=1 ! NEAR IR BEAM DOWNWARD SOLAR FLUX (W/M2) IDS(169)=1 ! NEAR IR DIFFUSE DOWNWARD SOLAR FLUX (W/M2) ! ! IDS(172)=4 ! MOMENTUM FLUX (N/M2) IDS(173)=0 ! MASS POINT MODEL SURFACE () IDS(174)=0 ! VELOCITY POINT MODEL SURFACE () IDS(175)=0 ! SIGMA LAYER NUMBER () IDS(176)=2 ! LATITUDE (DEGREES) IDS(177)=2 ! EAST LONGITUDE (DEGREES) ! ! ! IDS(181)=10 ! X-GRADIENT LOG PRESSURE (1/M) IDS(182)=10 ! Y-GRADIENT LOG PRESSURE (1/M) IDS(183)=6 ! X-GRADIENT HEIGHT (M/M) IDS(184)=6 ! Y-GRADIENT HEIGHT (M/M) ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! IDS(201)=0 ! ICE-FREE WATER SURCACE (PERCENT) ! ! IDS(204)=1 ! DOWNWARD SOLAR RADIATIVE FLUX (W/M2) IDS(205)=1 ! DOWNWARD LONGWAVE RADIATIVE FLUX (W/M2) ! IDS(207)=0 ! MOISTURE AVAILABILITY (PERCENT) ! EXCHANGE COEFFICIENT (KG/M2/S) IDS(209)=0 ! NUMBER OF MIXED LAYER NEXT TO SFC () ! IDS(211)=1 ! UPWARD SOLAR RADIATIVE FLUX (W/M2) IDS(212)=1 ! UPWARD LONGWAVE RADIATIVE FLUX (W/M2) IDS(213)=0 ! NON-CONVECTIVE CLOUD COVER (PERCENT) IDS(214)=7 ! CONVECTIVE PRECIPITATION RATE (KG/M2/S) IDS(215)=8 ! TOTAL DIABATIC HEATING RATE (K/S) IDS(216)=8 ! TOTAL RADIATIVE HEATING RATE (K/S) IDS(217)=8 ! TOTAL DIABATIC NONRADIATIVE HEATING RATE (K/S) IDS(218)=2 ! PRECIPITATION INDEX (FRACTION) IDS(219)=2 ! STD DEV OF IR T OVER 1X1 DEG AREA (K) IDS(220)=5 ! NATURAL LOG OF SURFACE PRESSURE OVER 1 KPA () IDS(221)=1 ! PLANETARY BOUNDARY LAYER HEIGHT (M) IDS(222)=1 ! 5-WAVE GEOPOTENTIAL HEIGHT (M) IDS(223)=2 ! PLANT CANOPY SURFACE WATER (KG/M2) ! ! ! BLACKADARS MIXING LENGTH (M) ! ASYMPTOTIC MIXING LENGTH (M) IDS(228)=2 ! POTENTIAL EVAPORATION (KG/M2) IDS(229)=1 ! SNOW PHASE-CHANGE HEAT FLUX (W/M2) IDS(230)=1 ! SNOW EVAPORATION (W/M2) IDS(231)=4 ! CONVECTIVE CLOUD MASS FLUX (PA/S) IDS(232)=1 ! DOWNWARD TOTAL RADIATION FLUX (W/M2) IDS(233)=1 ! UPWARD TOTAL RADIATION FLUX (W/M2) IDS(224)=2 ! BASEFLOW-GROUNDWATER RUNOFF (KG/M2) IDS(225)=2 ! STORM SURFACE RUNOFF (KG/M2) ! IDS(229)=1 ! SNOW PHASE_CHANGE HEAT FLUX (W/M2) IDS(230)=1 ! SNOW SUBLIMATION FLUX (W/M2) IDS(238)=1 ! SNOW COVER (PERCENT) IDS(239)=2 ! SNOW TEMPERATURE (K) ! IDS(241)=8 ! LARGE SCALE CONDENSATION HEATING RATE (K/S) IDS(242)=8 ! DEEP CONVECTIVE HEATING RATE (K/S) IDS(243)=11 ! DEEP CONVECTIVE MOISTENING RATE (KG/KG/S) IDS(244)=8 ! SHALLOW CONVECTIVE HEATING RATE (K/S) IDS(245)=11 ! SHALLOW CONVECTIVE MOISTENING RATE (KG/KG/S) IDS(246)=8 ! VERTICAL DIFFUSION HEATING RATE (KG/KG/S) IDS(247)=8 ! VERTICAL DIFFUSION ZONAL ACCELERATION (M/S/S) IDS(248)=8 ! VERTICAL DIFFUSION MERID ACCELERATION (M/S/S) IDS(249)=11 ! VERTICAL DIFFUSION MOISTENING RATE (KG/KG/S) IDS(250)=8 ! SOLAR RADIATIVE HEATING RATE (K/S) IDS(251)=8 ! LONGWAVE RADIATIVE HEATING RATE (K/S) ! DRAG COEFFICIENT () ! FRICTION VELOCITY (M/S) ! RICHARDSON NUMBER () ! ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END C----------------------------------------------------------------------- SUBROUTINE WRYTE(LU,LC,C) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRYTE WRITE DATA OUT BY BYTES C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 C C ABSTRACT: EFFICIENTLY WRITE UNFORMATTED A CHARACETER ARRAY. C C PROGRAM HISTORY LOG: C 91-10-31 MARK IREDELL C C USAGE: CALL WRYTE(LU,LC,C) C C INPUT ARGUMENT LIST: C LU - INTEGER UNIT TO WHICH TO WRITE C LC - INTEGER NUMBER OF CHARACTERS OR BYTES TO WRITE C C - CHARACETER (LC) DATA TO WRITE C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C C$$$ CHARACTER C(LC) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - WRITE(LU) C C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END SUBROUTINE IMINV (A,N,D,L,M) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: IMINV COMPUTES INVERSE OF MATRIX IN PLACE. C PRGMMR: JOSEPH SELA ORG: W/NMC23 DATE: 88-04-21 C C ABSTRACT: COMPUTES INVERSE OF MATRIX IN PLACE USING C GAUSS-JORDAN REDUCTION WITH MAX PIVOT. C C PROGRAM HISTORY LOG: C 88-04-21 IBM SCIENTIFIC SUBROUTINE PACKAGE. C C USAGE: CALL IMINV (A, N, D, L, M) C INPUT ARGUMENT LIST: C A - SQUARE MATRIX WHICH WILL BE INVERTED. C MATRIX A WILL BE DESTROYED AND REPLACED BY INVERSE. C N - ORDER OF MATRIX A. C C OUTPUT ARGUMENT LIST: C A - INVERSE OF INPUT MATRIX A. C D - DETERMINANT OF A INVERSE. C IF D=0.0, MATRIX A IS SINGULAR. C L - WORK VECTOR OF LENGTH N. C M - WORK VECTOR OF LENGTH N. C C ATTRIBUTES: C LANGUAGE: FORTRAN 200. C MACHINE: CYBER 205. C C$$$ C C .................................................................. C C ................ C C PURPOSE C INVERT A MATRIX C C USAGE C CALL IMINV (A,N,D,L,M) C C DESCRIPTION OF PARAMETERS C A - INPUT MATRIX, DESTROYED IN COMPUTATION AND REPLACED BY C RESULTANT INVERSE. C N - ORDER OF MATRIX A C D - RESULTANT DETERMINANT C L - WORK VECTOR OF LENGTH N C M - WORK VECTOR OF LENGTH N C C REMARKS C MATRIX A MUST BE A GENERAL MATRIX C C ............................................. C NONE C C METHOD C THE STANDARD GAUSS-JORDAN METHOD IS USED. THE DETERMINANT C IS ALSO CALCULATED. A DETERMINANT OF ZERO INDICATES THAT C THE MATRIX IS SINGULAR. C C .................................................................. C DIMENSION A(N*N),L(N),M(N) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION A, D, BIGA, HOLD C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SR........ MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. ABS IN STATEMEN C 10 MUST BE CHANGED TO DABS . C C ............................................................... C C SEARCH FOR LARGEST ELEMENT C D=1.0 E 0 NK=-N DO 80 K=1,N NK=NK+N L(K)=K M(K)=K KK=NK+K BIGA=A(KK) DO 20 J=K,N IZ=N*(J-1) DO 20 I=K,N IJ=IZ+I C 10 IF (DABS(BIGA)-DABS(A(IJ))) 15,20,20 10 IF( ABS (BIGA)- ABS (A(IJ))) 15,20,20 15 BIGA=A(IJ) L(K)=I M(K)=J 20 CONTINUE C C INTERCHANGE ROWS C J=L(K) IF(J-K) 35,35,25 25 KI=K-N DO 30 I=1,N KI=KI+N HOLD=-A(KI) JI=KI-K+J A(KI)=A(JI) 30 A(JI) =HOLD C C INTERCHANGE COLUMNS C 35 I=M(K) IF(I-K) 45,45,38 38 JP=N*(I-1) DO 40 J=1,N JK=NK+J JI=JP+J HOLD=-A(JK) A(JK)=A(JI) 40 A(JI) =HOLD C C DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS C CONTAINED IN BIGA) C 45 IF(BIGA) 48,46,48 46 D=0.0 E 0 RETURN 48 DO 55 I=1,N IF(I-K) 50,55,50 50 IK=NK+I A(IK)=A(IK)/(-BIGA) 55 CONTINUE C C REDUCE MATRIX C DO 65 I=1,N IK=NK+I IJ=I-N DO 65 J=1,N IJ=IJ+N IF(I-K) 60,65,60 60 IF(J-K) 62,65,62 62 KJ=IJ-I+K A(IJ)=A(IK)*A(KJ)+A(IJ) 65 CONTINUE C C DIVIDE ROW BY PIVOT C KJ=K-N DO 75 J=1,N KJ=KJ+N IF(J-K) 70,75,70 70 A(KJ)=A(KJ)/BIGA 75 CONTINUE C C PRODUCT OF PIVOTS C D=D*BIGA C C REPLACE PIVOT BY RECIPROCAL C A(KK)=1.0 E 0/BIGA 80 CONTINUE C C FINAL ROW AND COLUMN INTERCHANGE C K=N 100 K=(K-1) IF(K) 150,150,105 105 I=L(K) IF(I-K) 120,120,108 108 JQ=N*(K-1) JR=N*(I-1) DO 110 J=1,N JK=JQ+J HOLD=A(JK) JI=JR+J A(JK)=-A(JI) 110 A(JI) =HOLD 120 J=M(K) IF(J-K) 100,100,125 125 KI=K-N DO 130 I=1,N KI=KI+N HOLD=A(KI) JI=KI-K+J A(KI)=-A(JI) 130 A(JI) =HOLD GO TO 100 150 RETURN END SUBROUTINE ZNLDIA(NZNL,RHOUR,IDATE,KDT,LATB2,LEVS, & WGB,COLRAB,DEL) C DIMENSION IDATE(4) DIMENSION WGB(LATB2),COLRAB(LATB2),DEL(LEVS) C PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) C PARAMETER(NLEVP1= 28 +1) DIMENSION ZNLM(NLB,NLEVP1,NRM) C-CRA DIMENSION ZNLM(NLB,LEVS+1,NRM) DIMENSION ZNLS(NLB,NST,NRS) DIMENSION WEIM(NLB),WEIS(NLB,NST) C....................................................................... DO N=1,NLB WEIM(N)=0. DO M=1,NST WEIS(N,M)=0. ENDDO DO L=1,LEVS+1 DO M=1,NRM ZNLM(N,L,M)=0. ENDDO ENDDO DO M=1,NST DO K=1,NRS ZNLS(N,M,K)=0. ENDDO ENDDO ENDDO C DO LAT=1,LATB2 NLBH=NLB/2 WLB= 3.141593E+0 /(2*NLBH) JB=COLRAB(LAT)/WLB+1 JN=JB+1 JS=NLB-JB+1 C WEIM(JN)=WEIM(JN)+ZWM(1,LAT)*WGB(LAT) WEIM(JS)=WEIM(JS)+ZWM(2,LAT)*WGB(LAT) DO N=1,NRM IF(ZHM(N).GT.0.) THEN W=WGB(LAT)*ZHM(N) DO K=1,LEVS ZNLM(JN,K,N)=ZNLM(JN,K,N)+ZDM(1,K,N,LAT)*W ZNLM(JS,K,N)=ZNLM(JS,K,N)+ZDM(2,K,N,LAT)*W ENDDO ENDIF ENDDO C DO K=1,NST WEIS(JN,K)=WEIS(JN,K)+ZWS(1,K,LAT)*WGB(LAT) WEIS(JS,K)=WEIS(JS,K)+ZWS(2,K,LAT)*WGB(LAT) ENDDO DO N=1,NRS DO K=1,NST ZNLS(JN,K,N)=ZNLS(JN,K,N)+ZDS(1,K,N,LAT)*WGB(LAT) ZNLS(JS,K,N)=ZNLS(JS,K,N)+ZDS(2,K,N,LAT)*WGB(LAT) ENDDO ENDDO ENDDO C DO J=2,NLB WEIM(1)=WEIM(1)+WEIM(J) ENDDO DO K=1,LEVS DO J=2,NLB DO N=1,NRM ZNLM(1,K,N)=ZNLM(1,K,N)+ZNLM(J,K,N) ENDDO ENDDO ENDDO DO J=1,NLB DO K=1,LEVS DO N=1,NRM ZNLM(J,LEVS+1,N)=ZNLM(J,LEVS+1,N)+ZNLM(J,K,N)*DEL(K) ENDDO ENDDO ENDDO DO K=1,LEVS+1 DO J=1,NLB DO N=1,NRM IF(WEIM(J).NE.0.) ZNLM(J,K,N)=ZNLM(J,K,N)/WEIM(J) ENDDO ENDDO ENDDO C DO J=2,NLB DO K=1,NST WEIS(1,K)=WEIS(1,K)+WEIS(J,K) ENDDO ENDDO DO K=1,NST DO J=2,NLB DO N=1,NRS ZNLS(1,K,N)=ZNLS(1,K,N)+ZNLS(J,K,N) ENDDO ENDDO ENDDO DO K=1,NST DO J=1,NLB DO N=1,NRS IF(WEIS(J,K).NE.0.) ZNLS(J,K,N)=ZNLS(J,K,N)/WEIS(J,K) ENDDO ENDDO ENDDO C DO J=1,NLB IF(WEIS(1,1).NE.0.) ZNLS(J,1,NSSLMSK)=100.*WEIS(J,1)/WEIS(1,1) ENDDO DO K=2,NST DO J=1,NLB IF(WEIS(J,1).NE.0.) ZNLS(J,K,NSSLMSK)=100.*WEIS(J,K)/WEIS(J,1) ENDDO ENDDO C CALL ZNLPRT(NZNL,RHOUR,IDATE,KDT,LEVS+1,ZNLM,ZNLS) C RETURN END SUBROUTINE ZNLPRT(NZNL,RHOUR,IDATE,KDT,NLV,ZNLM,ZNLS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ZNLPRT PRINT ZONAL DIAGNOSTICS. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-03-15 C C ABSTRACT: PRINT ZONAL DIAGNOSTICS. C C PROGRAM HISTORY LOG: C 91-03-15 MARK IREDELL C C USAGE: CALL ZNLPRT (RHOUR,IDATE,KDT,NLB,NST,NLV, C & NRD,NRM,NRS,CND,CNM,CNS,ISD,ISM,ISS,ZNLD,ZNLM,ZNLS) C INPUT ARGUMENT LIST: C RHOUR - CURRENT FORECAST HOUR C IDATE - INITIAL HOUR,MONTH,DAY,YEAR C KDT - FORECAST STEP IF POSITIVE OR -100-DIAB.INI.STEP OR C -4 FOR INITIAL-DT DATA IN DIAB.INI C -3 FOR INITIAL DATA IN DIAB.INI C -2 FOR INITIAL-DT DATA C -1 FOR INITIAL DATA C 0 FOR DATA AFTER INITIALIZATION C NLB - NUMBER OF LATITUDE BANDS C NST - NUMBER OF SURFACE TYPES C NLV - NUMBER OF LEVELS C NRD - NUMBER OF 3D DYNAMICS FIELDS C NRM - NUMBER OF 3D PHYSICS FIELDS C NRS - NUMBER OF 2D PHYSICS FIELDS C CND - CHARACTER*8 IDENTIFICATIONS OF 3D DYNAMICS FIELDS C CNM - CHARACTER*8 IDENTIFICATIONS OF 3D PHYSICS FIELDS C CNS - CHARACTER*8 IDENTIFICATIONS OF 2D PHYSICS FIELDS C ISD - STATUS FLAGS OF 3D DYNAMICS FIELDS C ISM - STATUS FLAGS OF 3D PHYSICS FIELDS C ISS - STATUS FLAGS OF 2D PHYSICS FIELDS C ZNLD - ZONAL DIAGNOSTIC ARRAY OF 3D DYNAMICS FIELDS C ZNLM - ZONAL DIAGNOSTIC ARRAY OF 3D PHYSICS FIELDS C ZNLS - ZONAL DIAGNOSTIC ARRAY OF 2D PHYSICS FIELDS C C SUBPROGRAMS CALLED: C IPWRCN - FUNCTION TO DETERMINE ORDER OF MAGNITUDE OF OUTPUT C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) INTEGER IDATE(4) CHARACTER*8 CNM,CNS DIMENSION CNM(NRM),CNS(NRS) DIMENSION ZNLM(NLB,NLV,NRM) DIMENSION ZNLS(NLB,NST,NRS) PARAMETER(NNLV= 28 +1) DIMENSION WRKM(NLB,NNLV),WRKS(NLB,NST) C-CRA DIMENSION WRKM(NLB,NLV),WRKS(NLB,NST) CHARACTER*32 LABZ CHARACTER*8 CLB(6) CHARACTER*4 CST(6) CHARACTER*80 CFMT DATA CNM/'U ','V ','TV ','Q ','VOT**2 ', & 'DIV**2 ','OMEGA ','T ','RH ','KE ', & 'DTCONV ','DTLARG ','DTSHAL ','DTVRDF ','DQCONV ', & 'DQSHAL ','DQVRDF ','DUVRDF ','DVVRDF ','DTHSW ', & 'DTHLW ','CLOUD ','CVCLD '/ DATA CNS/'RAIN ','RAINC ','DTSFC ','DQSFC ','DUSFC ', & 'DVSFC ','RCOV ','RCOVC ','PS ','TSKIN ', & 'WETNESS ','SNOW ','TG1 ','TG2 ','TG3 ', & 'SFCSW ','SFCLW ','RHS ','TVS ','TS ', & 'QS ','ZORL ','SLMSK ','DUGWD ','DVGWD ', & 'DUASFC ','DUAGWD ','DUAMTN ','UA ','UAP ', & 'EP ','CLDWORK '/ DATA CLB/'90N-90S ','90N-60N ','60N-30N ','30N-30S ', & '30S-60S ','60S-90S '/ DATA CST/'MEAN',' LND','SLND',' ICE','SICE',' SEA'/ DATA NCOL/12/ C PRINT 900,KDT C DO 40 N=1,NRM IPWR=IPWRCN(CNM(N)) PRINT 910,CNM(N),IPWR,RHOUR,IDATE,KDT NROW=(NLV-1)/NCOL+1 DO 30 KROW=1,NROW K1=(KROW-1)*NCOL+1 IF(KROW.LT.NROW) THEN K2=K1-1+NCOL WRITE(CFMT,921) NCOL PRINT CFMT,(K,K=K1,K2) ELSEIF(K1.LT.NLV) THEN K2=NLV WRITE(CFMT,922) K2-K1 PRINT CFMT,(K,K=K1,K2-1) ELSE K2=NLV WRITE(CFMT,923) PRINT CFMT ENDIF WRITE(CFMT,930) -IPWR,K2-K1+1 PRINT CFMT,(CLB(J),(ZNLM(J,K,N),K=K1,K2),J=1,NLB) 30 CONTINUE 40 CONTINUE C DO 50 N=1,NRS IPWR=IPWRCN(CNS(N)) PRINT 910,CNS(N),IPWR,RHOUR,IDATE,KDT WRITE(CFMT,920) NST PRINT CFMT,(CST(K),K=1,NST) WRITE(CFMT,930) -IPWR,NST PRINT CFMT,(CLB(J),(ZNLS(J,K,N),K=1,NST),J=1,NLB) 50 CONTINUE C IF(NZNL.GT.0) THEN LABZ='ZNL 92/6' FSTEP=KDT DO J=1,NLV DO I=1,NLB WRKM(I,J)=0. ENDDO ENDDO DO J=1,NST DO I=1,NLB WRKS(I,J)=0. ENDDO ENDDO WRITE(NZNL)LABZ WRITE(NZNL)RHOUR,FSTEP,IDATE, & (((ZNLM(J,K,N),J=1,NLB),K=1,NLV),N= 1,10), & (((ZNLM(J,K,N),J=1,NLB),K=1,NLV),N=20,21), & ( WRKM ,N=13,30), & (((ZNLS(J,K,N),J=1,NLB),K=1,NST),N= 9,15), & ( WRKS ,N= 8,11), & (((ZNLS(J,K,N),J=1,NLB),K=1,NST),N=16,22), & ( WRKS ,N=19,29), & (((ZNLS(J,K,N),J=1,NLB),K=1,NST),N=23,23), & (((ZNLM(J,K,N),J=1,NLB),K=1,NLV),N=11,19), & ( WRKM ,N=10,30), & (((ZNLS(J,K,N),J=1,NLB),K=1,NST),N= 1, 8), & (((ZNLS(J,K,N),J=1,NLB),K=1,NST),N=24,30), & ( WRKS ,N=16,30) CLOSE(NZNL) ENDIF RETURN 900 FORMAT('0','ZONALLY AVERAGED DIAGNOSTICS',2X,'KDT=',I4) 910 FORMAT(1X,A8,' (10**',I3,')', & ' FHOUR=',F6.1,' IDATE= (',4I4,')',' KDT=',I4) 920 FORMAT("(5X,'--LAT-- ',",I2,"(5X,A4))") 921 FORMAT("(5X,'--LAT-- ',",I2,"(5X,'K=',I2))") 922 FORMAT("(5X,'--LAT-- ',",I2,"(5X,'K=',I2),5X,' SUM')") 923 FORMAT("(5X,'--LAT-- ', 5X,' SUM')") 930 FORMAT("(5X,A8,",I3,"P",I2,"F9.2))") END SUBROUTINE ZNLAVB(LAT,LONB2,LONB22,LEVS,SECPHY,SECRAD, & RBS2,SI,SL,DEL,PSEXP,GESHEM,BENGSH, & DUSFC,DVSFC,DTSFC,DQSFC,DUGWD,DVGWD, & SLMSK,SHELEG,TSEA,SOILM,TG1,TG2,TG3, & ZORL,EP,CLDWRK,DLWSFC,ULWSFC, & DG,TG,RQG,DLAM,DPHI,UG,VG) CFPP$ NOCONCUR R CFPP$ EXPAND(FPVS,ZNLAIM,ZNLAIS) C DIMENSION SI(LEVS+1),SL(LEVS),DEL(LEVS) DIMENSION PSEXP(LONB2) DIMENSION GESHEM(LONB2),BENGSH(LONB2) DIMENSION DUSFC(LONB2),DVSFC(LONB2) DIMENSION DTSFC(LONB2),DQSFC(LONB2) DIMENSION DUGWD(LONB2),DVGWD(LONB2) DIMENSION SLMSK(LONB2),SHELEG(LONB2) DIMENSION TSEA(LONB2),SOILM(LONB2) DIMENSION TG1(LONB2),TG2(LONB2),TG3(LONB2) DIMENSION ZORL(LONB2),EP(LONB2),CLDWRK(LONB2) DIMENSION DLWSFC(LONB2),ULWSFC(LONB2) DIMENSION DG(LONB22,LEVS) DIMENSION TG(LONB22,LEVS),RQG(LONB22,LEVS) DIMENSION DLAM(LONB2),DPHI(LONB2) DIMENSION UG(LONB22,LEVS),VG(LONB22,LEVS) C PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) C PARAMETER(CP= 1.0046E+3 ,RD= 2.8705E+2 ,RV= 4.6150E+2 ) PARAMETER(FKAPPA=RD/CP,FVIRT=RV/RD-1.,FEPS=RD/RV,FEPSM1=RD/RV-1.) C-CRA DIMENSION IST(LONB2) DIMENSION IST( 384 ) C-CRA DIMENSION WORK(LONB2,LEVS),WORK1(LONB2) DIMENSION WORK( 384 , 28 ),WORK1( 384 ) C LONB=LONB2/2 C ZWM(1,LAT)=0. ZWM(2,LAT)=0. DO I=1,LONB ZWM(1,LAT)=ZWM(1,LAT)+PSEXP(I) ZWM(2,LAT)=ZWM(2,LAT)+PSEXP(I+LONB) ENDDO C DO I=1,LONB2 WORK1(I)=0. ENDDO DO K=LEVS,1,-1 DO I=1,LONB2 CG1=RBS2*(UG(I,K)*DLAM(I)+VG(I,K)*DPHI(I)) CG2=CG1+DG(I,K) WORK1(I)=WORK1(I)+CG2*(SL(K)-SI(K+1)) WORK(I,K)=FKAPPA*TG(I,K)*(CG1-WORK1(I)/SL(K)) WORK1(I)=WORK1(I)+CG2*(SI(K)-SL(K)) ENDDO ENDDO CALL ZNLAIM(LONB2,WORK,PSEXP,NMOMEGA,LAT) C DO K=1,LEVS DO I=1,LONB2 WORK(I,K)=TG(I,K)*(1.+FVIRT*RQG(I,K)) ENDDO ENDDO CALL ZNLAIM(LONB2,WORK,PSEXP,NMTV,LAT) C DO K=1,LEVS DO I=1,LONB2 ES=FPVS(TG(I,K)) QS=FEPS*ES/(SL(K)*PSEXP(I)+FEPSM1*ES) WORK(I,K)=100.*RQG(I,K)/QS ENDDO ENDDO CALL ZNLAIM(LONB2,WORK,PSEXP,NMRH,LAT) C DO K=1,LEVS DO I=1,LONB2 WORK(I,K)=RBS2*0.5*(UG(I,K)**2+VG(I,K)**2) ENDDO ENDDO CALL ZNLAIM(LONB2,WORK,PSEXP,NMKE,LAT) C DO K=1,LEVS DO I=1,LONB2 WORK(I,K)=DG(I,K)**2 ENDDO ENDDO CALL ZNLAIM(LONB2,WORK,PSEXP,NMDIV2,LAT) C CALL ZNLAIM(LONB22,UG,PSEXP,NMU,LAT) CALL ZNLAIM(LONB22,VG,PSEXP,NMV,LAT) CALL ZNLAIM(LONB22,TG,PSEXP,NMT,LAT) CALL ZNLAIM(LONB22,RQG,PSEXP,NMQ,LAT) C WGINST=1. WGTIME=0. IF(SECPHY.GT.0.) WGTIME=1./SECPHY WRTIME=0. IF(SECRAD.GT.0.) WRTIME=1./SECRAD ZHM(NMU)=WGINST ZHM(NMV)=WGINST ZHM(NMTV)=WGINST ZHM(NMQ)=WGINST ZHM(NMVOT2)=0. ZHM(NMDIV2)=WGINST ZHM(NMOMEGA)=WGINST ZHM(NMT)=WGINST ZHM(NMRH)=WGINST ZHM(NMKE)=WGINST ZHM(NMTCONV)=WGTIME ZHM(NMTLARG)=WGTIME ZHM(NMTSHAL)=WGTIME ZHM(NMTVRDF)=WGTIME ZHM(NMQCONV)=WGTIME ZHM(NMQSHAL)=WGTIME ZHM(NMQVRDF)=WGTIME ZHM(NMUVRDF)=WGTIME ZHM(NMVVRDF)=WGTIME ZHM(NMTHSW)=WGTIME ZHM(NMTHLW)=WGTIME ZHM(NMTCLD)=WRTIME ZHM(NMTCCV)=WRTIME C DO I=1,LONB2 IF(SLMSK(I).EQ.0.) THEN IST(I)=6 ELSEIF(SLMSK(I).EQ.1.) THEN IST(I)=2 IF(SHELEG(I).GT.1.E-3) IST(I)=3 ELSE IST(I)=4 IF(SHELEG(I).GT.1.E-3) IST(I)=5 ENDIF ENDDO ZWS(1,1,LAT)=LONB ZWS(2,1,LAT)=LONB DO K=2,NST ZWS(1,K,LAT)=0. ZWS(2,K,LAT)=0. ENDDO DO I=1,LONB ZWS(1,IST(I),LAT)=ZWS(1,IST(I),LAT)+1. ZWS(2,IST(I+LONB),LAT)=ZWS(2,IST(I+LONB),LAT)+1. ENDDO C ACL= 6.3712E+6 /SQRT(RBS2) DO I=1,LONB2 WORK1(I)=0. ENDDO DO K=1,LEVS DO I=1,LONB2 WORK1(I)=WORK1(I)+DEL(K)*UG(I,K) ENDDO ENDDO UAFAC= 6.3712E+6 *1.E3/ 9.8000E+0 DO I=1,LONB2 WORK1(I)=UAFAC*PSEXP(I)*WORK1(I) ENDDO CALL ZNLAIS(WORK1,IST,1.,NSUA,LAT) C UAFAC= 7.2921E-5 *ACL*ACL*1.E3/ 9.8000E+0 UAREF= 7.2921E-5 *ACL*ACL*1.E4 DO I=1,LONB2 WORK1(I)=UAFAC*PSEXP(I)-UAREF ENDDO CALL ZNLAIS(WORK1,IST,1.,NSUAP,LAT) C DO I=1,LONB2 WORK1(I)=TG(I,1)*(1.+FVIRT*RQG(I,1)) ENDDO CALL ZNLAIS(WORK1,IST,1.,NSTVS,LAT) C DO I=1,LONB2 ES=FPVS(TG(I,1)) QS=FEPS*ES/(SL(1)*PSEXP(I)+FEPSM1*ES) WORK1(I)=100.*RQG(I,1)/QS ENDDO CALL ZNLAIS(WORK1,IST,1.,NSRHS,LAT) C CALL ZNLAIS(SHELEG,IST,1.,NSSNOW,LAT) CALL ZNLAIS(PSEXP,IST,1.,NSPS,LAT) CALL ZNLAIS(TG(1,1),IST,1.,NSTS,LAT) CALL ZNLAIS(RQG(1,1),IST,1.,NSQS,LAT) CALL ZNLAIS(TSEA,IST,1.,NSTSKIN,LAT) CALL ZNLAIS(SOILM,IST,1.,NSWET,LAT) CALL ZNLAIS(TG1,IST,1.,NSTG1,LAT) CALL ZNLAIS(TG2,IST,1.,NSTG2,LAT) CALL ZNLAIS(TG3,IST,1.,NSTG3,LAT) CALL ZNLAIS(ZORL,IST,1.,NSZORL,LAT) C IF(SECPHY.GT.0.) THEN DO I=1,LONB2 WORK1(I)=0. IF(GESHEM(I).GT.0.) WORK1(I)=100. ENDDO CALL ZNLAIS(WORK1,IST,1.,NSRCOV,LAT) C DO I=1,LONB2 WORK1(I)=0. IF(BENGSH(I).GT.0.) WORK1(I)=100. ENDDO CALL ZNLAIS(WORK1,IST,1.,NSRCOVC,LAT) C DO I=1,LONB2 WORK1(I)=ULWSFC(I)-DLWSFC(I) ENDDO CALL ZNLAIS(WORK1,IST,1./SECPHY,NSSFCLW,LAT) C CALL ZNLAIS(GESHEM,IST,86400./SECPHY,NSRAIN,LAT) CALL ZNLAIS(BENGSH,IST,86400./SECPHY,NSRAINC,LAT) CALL ZNLAIS(DUSFC,IST,1./SECPHY,NSUSFC,LAT) CALL ZNLAIS(DVSFC,IST,1./SECPHY,NSVSFC,LAT) CALL ZNLAIS(DUGWD,IST,1./SECPHY,NSUGWD,LAT) CALL ZNLAIS(DVGWD,IST,1./SECPHY,NSVGWD,LAT) CALL ZNLAIS(DUSFC,IST,ACL/SECPHY,NSUASFC,LAT) CALL ZNLAIS(DUGWD,IST,ACL/SECPHY,NSUAGWD,LAT) CALL ZNLAIS(DTSFC,IST,1./SECPHY,NSTSFC,LAT) CALL ZNLAIS(DQSFC,IST,1./SECPHY,NSQSFC,LAT) CALL ZNLAIS(EP,IST,1./SECPHY,NSEP,LAT) CALL ZNLAIS(CLDWRK,IST,1./SECPHY,NSCLDWRK,LAT) ENDIF C RETURN END SUBROUTINE ZNLAVZ(LATB2,LONB2,SECPHY,SECRAD, & DUMTN,SLMSK,SHELEG,DSWSFC,USWSFC) CFPP$ EXPAND(ZNLAIS) C DIMENSION DUMTN(LONB2,LATB2) DIMENSION SLMSK(LONB2,LATB2),SHELEG(LONB2,LATB2) DIMENSION DSWSFC(LONB2,LATB2),USWSFC(LONB2,LATB2) C PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) C C-CRA DIMENSION IST(LONB2) C-CRA DIMENSION WORK1(LONB2) DIMENSION IST( 384 ) DIMENSION WORK1( 384 ) C CFPP$ PRIVATEARRAY DO LAT=1,LATB2 C DO I=1,LONB2 IF(SLMSK(I,LAT).EQ.0.) THEN IST(I)=6 ELSEIF(SLMSK(I,LAT).EQ.1.) THEN IST(I)=2 IF(SHELEG(I,LAT).GT.1.E-3) IST(I)=3 ELSE IST(I)=4 IF(SHELEG(I,LAT).GT.1.E-3) IST(I)=5 ENDIF ENDDO C IF(SECRAD.GT.0.) THEN DO I=1,LONB2 WORK1(I)=USWSFC(I,LAT)-DSWSFC(I,LAT) ENDDO CALL ZNLAIS(WORK1,IST,1./SECRAD,NSSFCSW,LAT) ENDIF C IF(SECPHY.GT.0.) THEN CALL ZNLAIS(DUMTN(1,LAT),IST,1./SECPHY,NSUAMTN,LAT) ENDIF C ENDDO C RETURN END CFPP$ NOCONCUR R SUBROUTINE ZNLACM(NLONX,A,PS,DT,KD,LAT) PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) DIMENSION A(NLONX, 28 ),PS( 384 ) C NLON= 384 /2 DO 20 K=1, 28 DO 10 I=1,NLON I1=I I2=I+NLON ZDM(1,K,KD,LAT)=ZDM(1,K,KD,LAT)+A(I1,K)*PS(I1)*DT ZDM(2,K,KD,LAT)=ZDM(2,K,KD,LAT)+A(I2,K)*PS(I2)*DT 10 CONTINUE 20 CONTINUE C RETURN END CFPP$ NOCONCUR R SUBROUTINE ZNLAIM(NLONX,A,PS,KD,LAT) PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) DIMENSION A(NLONX, 28 ),PS( 384 ) C NLON= 384 /2 DO 20 K=1, 28 ZDM(1,K,KD,LAT)=0. ZDM(2,K,KD,LAT)=0. DO 10 I=1,NLON I1=I I2=I+NLON ZDM(1,K,KD,LAT)=ZDM(1,K,KD,LAT)+A(I1,K)*PS(I1) ZDM(2,K,KD,LAT)=ZDM(2,K,KD,LAT)+A(I2,K)*PS(I2) 10 CONTINUE 20 CONTINUE C RETURN END CFPP$ NOCONCUR R SUBROUTINE ZNLAIS(A,IST,FAC,KD,LAT) PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) DIMENSION A( 384 ) DIMENSION IST( 384 ) C NLON= 384 /2 DO K=1,NST ZDS(1,K,KD,LAT)=0. ZDS(2,K,KD,LAT)=0. ENDDO DO I=1,NLON I1=I I2=I+NLON ZDS(1,1,KD,LAT)=ZDS(1,1,KD,LAT)+A(I1)*FAC ZDS(2,1,KD,LAT)=ZDS(2,1,KD,LAT)+A(I2)*FAC ENDDO DO I=1,NLON I1=I I2=I+NLON ZDS(1,IST(I1),KD,LAT)=ZDS(1,IST(I1),KD,LAT)+A(I1)*FAC ZDS(2,IST(I2),KD,LAT)=ZDS(2,IST(I2),KD,LAT)+A(I2)*FAC ENDDO C RETURN END FUNCTION IPWRCN(CN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: IPWRCN GET EXPECTED ORDER OF MAGNITUDE OF A FIELD. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-03-15 C C ABSTRACT: INTEGER FUNCTION TO RETURN THE EXPECTED C ORDER OF MAGNITUDE OF A FIELD GIVEN ITS NAME. C C PROGRAM HISTORY LOG: C 91-03-15 MARK IREDELL C C USAGE: I = IPWRCN (CN) C INPUT ARGUMENT LIST: C CN - CHARACTER*8 FIELD NAME C C OUTPUT ARGUMENT LIST: C IPWRCN - EXPECTED ORDER OF MAGNITUDE C C SUBPROGRAMS CALLED: C (ISC8) - CHARACTER*8 STRING SEARCH C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ PARAMETER(NL=56) CHARACTER*8 CN CHARACTER*8 CNL(NL) INTEGER IPL(0:NL) SAVE CNL,IPL DATA IPL(0)/0/ DATA CNL( 1)/'U '/, IPL( 1)/0/ DATA CNL( 2)/'V '/, IPL( 2)/0/ DATA CNL( 3)/'TV '/, IPL( 3)/0/ DATA CNL( 4)/'Q '/, IPL( 4)/-3/ DATA CNL( 5)/'VOT**2 '/, IPL( 5)/-12/ DATA CNL( 6)/'DIV**2 '/, IPL( 6)/-12/ DATA CNL( 7)/'OMEGA '/, IPL( 7)/-5/ DATA CNL( 8)/'T '/, IPL( 8)/0/ DATA CNL( 9)/'RH '/, IPL( 9)/0/ DATA CNL(10)/'KE '/, IPL(10)/0/ DATA CNL(11)/'PD '/, IPL(11)/-1/ DATA CNL(12)/'DTCONV '/, IPL(12)/-5/ DATA CNL(13)/'DTLARG '/, IPL(13)/-5/ DATA CNL(14)/'DTSHAL '/, IPL(14)/-5/ DATA CNL(15)/'DTVRDF '/, IPL(15)/-5/ DATA CNL(16)/'DQCONV '/, IPL(16)/-8/ DATA CNL(17)/'DQSHAL '/, IPL(17)/-8/ DATA CNL(18)/'DQVRDF '/, IPL(18)/-8/ DATA CNL(19)/'DUVRDF '/, IPL(19)/-5/ DATA CNL(20)/'DVVRDF '/, IPL(20)/-5/ DATA CNL(21)/'DTHSW '/, IPL(21)/-5/ DATA CNL(22)/'DTHLW '/, IPL(22)/-5/ CDG3.. INSERTED MULTI-LAYERED CLOUD HERE, RATHER THAN AT THE END, CDG3.. SINCE IT SEEMS TO BE JUST BEFORE THE SINGLE LYR DATA...KAC DATA CNL(23)/'CLOUD '/, IPL(23)/0/ DATA CNL(24)/'CVCLD '/, IPL(24)/0/ DATA CNL(25)/'RAIN '/, IPL(25)/-3/ DATA CNL(26)/'RAINC '/, IPL(26)/-3/ DATA CNL(27)/'DTSFC '/, IPL(27)/0/ DATA CNL(28)/'DQSFC '/, IPL(28)/0/ DATA CNL(29)/'DUSFC '/, IPL(29)/-3/ DATA CNL(30)/'DVSFC '/, IPL(30)/-3/ DATA CNL(31)/'RCOV '/, IPL(31)/0/ DATA CNL(32)/'RCOVC '/, IPL(32)/0/ DATA CNL(33)/'TSKIN '/, IPL(33)/0/ DATA CNL(34)/'WETNESS '/, IPL(34)/0/ DATA CNL(35)/'SNOW '/, IPL(35)/1/ DATA CNL(36)/'TG1 '/, IPL(36)/0/ DATA CNL(37)/'TG2 '/, IPL(37)/0/ DATA CNL(38)/'TG3 '/, IPL(38)/0/ DATA CNL(39)/'SFCSW '/, IPL(39)/0/ DATA CNL(40)/'SFCLW '/, IPL(40)/0/ DATA CNL(41)/'ZORL '/, IPL(41)/0/ DATA CNL(42)/'SLMSK '/, IPL(42)/0/ DATA CNL(43)/'PS '/, IPL(43)/-1/ DATA CNL(44)/'TVS '/, IPL(44)/0/ DATA CNL(45)/'QS '/, IPL(45)/-3/ DATA CNL(46)/'TS '/, IPL(46)/0/ DATA CNL(47)/'RHS '/, IPL(47)/0/ DATA CNL(48)/'DUGWD '/, IPL(48)/-3/ DATA CNL(49)/'DVGWD '/, IPL(49)/-3/ DATA CNL(50)/'UA '/, IPL(50)/10/ DATA CNL(51)/'UAP '/, IPL(51)/10/ DATA CNL(52)/'DUASFC '/, IPL(52)/3/ DATA CNL(53)/'DUAGWD '/, IPL(53)/3/ DATA CNL(54)/'DUAMTN '/, IPL(54)/3/ DATA CNL(55)/'EP '/, IPL(55)/0/ DATA CNL(56)/'CLDWORK '/, IPL(56)/0/ C N=ISC8(NL,CNL,CN) IPWRCN=IPL(N) RETURN END FUNCTION ISC8(N,CA,CI) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ISC8 FIND A CHARACTER*8 STRING. C PRGMMR: MARK IREDELL ORG: W/NMC23 DATE: 91-03-15 C C ABSTRACT: INTEGER FUNCTION TO RETURN THE INDEX OF A CHARACTER*8 NAME. C C PROGRAM HISTORY LOG: C 91-03-15 MARK IREDELL C C USAGE: I=ISC8 (N,CA,CI) C INPUT ARGUMENT LIST: C N - NUMBER OF STRINGS TO SEARCH C CA - CHARACTER*8 ARRAY TO SEARCH C CI - CHARACTER*8 STRING FOR WHICH TO SEARCH C C OUTPUT ARGUMENT LIST: C ISC8 - INDEX OF FIRST STRING FOUND OR 0 IF NOT FOUND C C REMARKS: THIS ROUTINE MAY BE INLINED. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77. C MACHINE: CRAY YMP. C C$$$ CHARACTER*8 CA(N),CI DO 10 I=1,N IF(CA(I).EQ.CI) THEN ISC8=I RETURN ENDIF 10 CONTINUE ISC8=0 RETURN END SUBROUTINE ZNLZER PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) DO M=1, 47 DO L=1,NRM DO K=1, 28 DO J=1,2 ZDM(J,K,L,M)=0. ENDDO ENDDO ENDDO ENDDO DO M=1, 47 DO L=1,NRS DO K=1,NST DO J=1,2 ZDS(J,K,L,M)=0. ENDDO ENDDO ENDDO ENDDO RETURN END SUBROUTINE ZNLMLT(FAC) PARAMETER(NRM=23,NRS=32) PARAMETER(NLB=6,NST=6) PARAMETER(NMU=1,NMV=2,NMTV=3,NMQ=4,NMVOT2=5, & NMDIV2=6,NMOMEGA=7,NMT=8,NMRH=9,NMKE=10, & NMTCONV=11,NMTLARG=12,NMTSHAL=13,NMTVRDF=14,NMQCONV=15, & NMQSHAL=16,NMQVRDF=17,NMUVRDF=18,NMVVRDF=19,NMTHSW=20, & NMTHLW=21,NMTCLD=22,NMTCCV=23) PARAMETER(NSRAIN=1,NSRAINC=2,NSTSFC=3,NSQSFC=4,NSUSFC=5, & NSVSFC=6,NSRCOV=7,NSRCOVC=8,NSPS=9,NSTSKIN=10, & NSWET=11,NSSNOW=12,NSTG1=13,NSTG2=14,NSTG3=15, & NSSFCSW=16,NSSFCLW=17,NSRHS=18,NSTVS=19,NSTS=20, & NSQS=21,NSZORL=22,NSSLMSK=23,NSUGWD=24,NSVGWD=25, & NSUASFC=26,NSUAGWD=27,NSUAMTN=28,NSUA=29,NSUAP=30, & NSEP=31,NSCLDWRK=32) COMMON /COMZNL/ ZDM(2, 28 ,NRM, 47 ),ZWM(2, 47 ),ZHM(NRM) COMMON /COMZNL/ ZDS(2,NST,NRS, 47 ),ZWS(2,NST, 47 ) DO M=1, 47 DO L=1,NRM DO K=1, 28 DO J=1,2 ZDM(J,K,L,M)=ZDM(J,K,L,M)*FAC ENDDO ENDDO ENDDO ENDDO DO M=1, 47 DO L=1,NRS DO K=1,NST DO J=1,2 ZDS(J,K,L,M)=ZDS(J,K,L,M)*FAC ENDDO ENDDO ENDDO ENDDO RETURN END