PROGRAM TWOD C****************************************************************************** C This program runs a two-dimensional hydrostatic model containing C parameterizations of convection, clouds and radiative transfer. The model C may be oriented in the east-west direction with periodic boundaries, C or in the north-south direction with rigid boundaries. Radiation and C ocean mixed layer temperature may be calculated or specified in the input C sounding file. The model is nonlinear, except that the advection of the C overturning circulation by itself is neglected. Standard Fickian C diffusion modifies the wind variables, but not temperature or specific C humidity. The parameter NLO specifies the number of grid columns; it C must be at least 4. The number of vertical levels is specified in the C input sounding file. C C There are two input files that must be supplied: sounding.in, which C contains one vertical sounding of all the model variables for each C grid column, and params.in, which contains most of the parameters C used to control the model. There must be at least as many sounding C columns in sounding.in as NLO-2. C C Output consists of the file sounding.out, whose format is identical to C that of sounding.in, and a series of matrix files containing time- C distance series and distance-pressure cross-section averaged over C the last n time steps of the integration, where n is specified in C params.in. One may specify these files to be in matlab-readable ASCII C format or comma-separated ASCII format. The matlab script files C imenux and imenuy provide ways of displaying the output. C C The main program and subroutine CONVECT were created by Kerry Emanuel (Emanuel C and Zivkovic-Rothman, J. Atmos. Sci., 1999, 1766-1782), the fractioanl cloud C scheme by Sandrine Bony (Bony and Emanuel, J. Atmos. Sci., 2001, 3158-3183) C and the radiation code was developed by J.-J. Morcrette (J. Geophys. Res., 1991, C 9121-9132). The radiation subroutine may be deleted if radiative cooling is C specified; this will result in faster compilation and running. C C***************************************************************************** C C Note: The parameter NA must be greater than or equal to the total number C of model levels at which the state variables are defined. This will C equal the number of tropospheric levels plus 9. NOTE THAT NA MUST BE C SET TO THE SAME VALUE IN SUBROUTINE CONVECT. NTIME is at least the C number of time steps that certain quanitities like precipitation are C output to the graphics arrays. NCL is the number of cloud types C used by the radiation code. C PARAMETER (NA=50, NAP=NA+1, NTIME=5000, NCL=1) PARAMETER (NLO=4) C C Dimension various arrays C C Temperatures: C REAL T1(NLO,NA), T2(NLO,NA), T3(NLO,NA), TTEMP(NA) REAL TCONV(NA),RCONV(NA), T0(NLO,NA) REAL TVP(NA), TMEAN(NLO,NA) C C Surface temperatures: C REAL TS1(NLO),TS2(NLO),TS3(NLO) C C Specific humidities: C REAL R1(NLO,NA), R2(NLO,NA), R3(NLO,NA), RS(NA) REAL RT(NLO,NA), RV2(NA) REAL RTEMP(NA), R0(NLO,NA), RMEAN(NLO,NA) C C Other quantities in convection scheme: C REAL UC(NA),VC(NA),VCO(NA),UCO(NA) REAL TRA1(NA,1) C C Pressures: C REAL P(NA), PH(NAP), PHRAD(NAP) REAL SPONGE(NA) C C Latitudes: C REAL RLAT(NLO), COSZA(NLO), COSLAT(NLO) C C Ozone used in radiative calculation: C REAL O3(NA) C C Streamfunction and zonal wind C REAL PSI(NLO,NA), U(NA), FC(NLO) REAL ETA1(NLO,NA),ETA2(NLO,NA),ETA3(NLO,NA) REAL U1(NLO,NA), U2(NLO,NA), U3(NLO,NA) C C Background meridional wind and T gradient C REAL VZ(NA), TX(NA) C C *** Applied Omega *** C REAL AOMEGA(NA) C C Forcings: C REAL FT(NA), FR(NA), FTNET(NLO,NA), FRNET(NLO,NA) REAL FTS(NLO),ETAF(NLO,NA),UF(NLO,NA),RADFLUX(NLO) REAL FTRA(NA,1),FUC(NA),FVC(NA) REAL FTADJ(NA), FRADJ(NA),VMAXK(NLO) C C Radiative arrays: C REAL RCOOL(NLO,NA), CS(NCL), PCTOP(NCL), PCBOT(NCL), TAUS(NCL) REAL FNETIR(NAP), FNETSO(NAP), COOLR(NA), HEATR(NA), HOUR REAL QCONDT(NA) REAL HOUR0 REAL MEAN,QSAT,CLDF(NA),CLDQ(NA),SIGSUB(NA),QSUBGRID : ,gsol,minimum,xo,ho,pi,qmin,qmax,pas,signe,x : ,delta(NA),TIMEL,essai : ,RSNEWLS(NA), RNEWLS(NA), TNEWLS(NA) : ,CLDFRAD(NA), CLDQRAD(NA) REAL rmumean(NLO), fracmean(NLO), albmean(NLO) CHARACTER*1 RADINT, TSINT, TDEP, DDEP, DARAD, ANRAD, CALB CHARACTER*1 RESTART C C Clouds and radiation C integer julien real CLDEMI(NA), CLDTAU(NA), CLDFICE(NA), CLDT, CLDWP : ,zlongi, dist, RLON, gmtime, albsol, RCOTN(NLO,NA) : ,pplay(NA), paprs(NAP), RCOTNOLD(NA) : ,RCLW(NA),RCSW(NA),RCLWOLD(NA),RCSWOLD(NA) : ,fract,rmu0 : ,heat(NA),heat0(NA),cool(NA),cool0(NA) : ,radsol,albpla,topsw,toplw,solsw,sollw : ,topsw0,toplw0,solsw0,sollw0 : ,radsolold,radsoln C C Surface arrays C REAL EFRAC(NLO), DEPTH(NLO), SALB(NLO), FSOIL(NLO) REAL FS(NLO), FL(NLO) C C Soil arrays C REAL SM1(NLO), SM2(NLO), SM3(NLO) C C Convective momentum transport C REAL FVCNET(NLO,NA) C C Saved arrays C REAL RV2M(NA),CLDEMIM(NA),CLDTAUM(NA),CLDFRADM(NA) C C Character constants C CHARACTER*1 WDEP,BCS,FWRITE,ICLOUD,IVAPOR,ISOIL C C Convective quantities used for diagnostics: C REAL MP(NA), RP(NA), SIJ(NA,NA), WATER(NA) REAL CBMFA(NLO),FRSUB(NA) REAL MUP(NA), MDOWN(NA), ENT(NA), DET(NA) REAL FRDET(NA) C C Time-dependent quantities for graphics output: C REAL QGRAPH(NLO,NTIME),OGRAPH(NLO,NTIME),PGRAPH(NLO,NTIME) REAL VGRAPH(NLO,NTIME),UTGRAPH(NLO,NTIME),GTIME(NTIME) REAL SSTGRAPH(NLO,NTIME), MPIGRAPH(NLO,NTIME) REAL T100GRAPH(NLO,NTIME), T100BAR(NLO), EFBAR(NLO) REAL SWGRAPH(NLO,NTIME), CAPEGRAPH(NLO,NTIME) REAL CAPEBAR(NLO), QRBAR(NLO), QRGRAPH(NLO,NTIME) REAL OLRGRAPH(NLO,NTIME),HCGRAPH(NLO,NTIME) REAL LCGRAPH(NLO,NTIME), EFRACGRAPH(NLO,NTIME) REAL*8 TIME C C Space-dependent quantities for output: C REAL OLGRAPH(NLO,NA),MUPGRAPH(NLO,NA),MDGRAPH(NLO,NA) REAL PREBAR(NLO),RHGRAPH(NLO,NA),ULGRAPH(NLO,NA) REAL OBAR(NLO),VBAR(NLO),UBAR(NLO),SSTBAR(NLO) REAL PSIGRAPH(NLO,NA),MUPG(NLO,NA),MDG(NLO,NA),RHG(NLO,NA) REAL OLG(NLO,NA),TEMPGRAPH(NLO,NA), AMGRAPH(NLO,NA) REAL AFLUXGRAPH(NLO),OFLUXGRAPH(NLO),AFLUX(NLO),OFLUX(NLO) REAL VOCEAN(NLO), CLDTEMP(NLO,NA), CLDGRAPH(NLO,NA) REAL NETFLUX(NLO), NETFLUXGRAPH(NLO) REAL SWBAR(NLO), TEMPGRAPHNET(NLO,NA) REAL OLRBAR(NLO),LCBAR(NLO),HCBAR(NLO) C C Special graphics arrays: C REAL DISX(NLO) C C Latent heat at T=0 C C REAL LV0 C LOGICAL ok, correc, correc2, rad1st, radcomp : ,newobs,nodomega,newqlw,evap_prec : ,correctd C C Common block with subroutine CONVECT: C COMMON / CVT / TVP,MP,RP,SIJ,MUP,MDOWN,ENT,DET,FRDET,FRSUB, 1 WATER,INB, CAPEM C C Common block with subroutine CLOUDS_SUB_LS: C REAL CLDL(NA),CLDA(NA),CLDK(NA),CLDS(NA) COMMON / cldpara / CLDL, CLDA, CLDK, CLDS c ------------------------------------------------------- c OPTIONS OF THE SIMULATION: c ------------------------------------------------------- c if radcomp=T: the rad tendency added to net tendencies is computed: radcomp = .TRUE. c maximum precipitation efficiency: EPMAX = 0.999 c minimum precipitation efficiency: EPMIN = 0.0 C rad1st = .FALSE. C C Open input and output files: C OPEN(UNIT=8, FILE='params.in', STATUS='OLD') OPEN(UNIT=11, FILE='output/error.out', STATUS='unknown') C C C Read in the parameters of the model from the file params.in C READ(8,*) READ(8,*) READ(8,*) READ(8,*) READ(8,*)RESTART READ(8,*)ENDTIME READ(8,*)DT READ(8,*) READ(8,*) READ(8,*) READ(8,*)AWN READ(8,*)RLATB READ(8,*)RLATE READ(8,*)RLONB READ(8,*)RLONE READ(8,*)KSOIL READ(8,*)BCS READ(8,*) READ(8,*) READ(8,*) READ(8,*)RADINT READ(8,*)RADFREQ READ(8,*)TSINT READ(8,*)IVAPOR READ(8,*)ICLOUD READ(8,*)SCON READ(8,*)CO2 READ(8,*)MONTH READ(8,*)IDAY READ(8,*)HOUR READ(8,*)TDEP READ(8,*)DDEP READ(8,*)DARAD READ(8,*)ANRAD READ(8,*)CALB READ(8,*)ALB READ(8,*)ALBLAND READ(8,*) READ(8,*) READ(8,*) READ(8,*)WDEP READ(8,*)US0 READ(8,*)VS0 READ(8,*)WS0 READ(8,*) READ(8,*) READ(8,*) READ(8,*)ISOIL READ(8,*)EFRACR READ(8,*)TAUSOIL READ(8,*)TAURUNOFF READ(8,*)SBETA READ(8,*) READ(8,*) READ(8,*) READ(8,*)DEPTHR READ(8,*)CCOUP READ(8,*) READ(8,*) READ(8,*) READ(8,*)DPBL READ(8,*)DAMP READ(8,*)SCOEF READ(8,*)PFIX READ(8,*) READ(8,*) READ(8,*) READ(8,*)PRINFREQ READ(8,*)PAVE READ(8,*)VTRANS READ(8,*)FWRITE C C Renormalize certain parameters C C RDAMP=4./(RADFREQ*3600.) AOMEGMAX=0.0 RDAMP=0.0 DT=DT*60.0 DAMP=1.0/(24.*3600.*DAMP) PNUM=100.*DAMP SCOEF=1.0/(60.*SCOEF) TDEEP=TDEEP+273.15 AOMEGMAX=AOMEGMAX/36.0 ALENGTH=1.0E6*AWN DX=ALENGTH/FLOAT(NLO-2) DXI=1.0/DX DTI=1.0/DT DPBLI=1.0/DPBL ENDTIME=ENDTIME*3600.0*24.0+HOUR*3600. RADFREQ=RADFREQ*3600.0 PRINFREQ=PRINFREQ*3600.0 PAVE=PAVE*24.*3600. PAVE=MIN(PAVE,ENDTIME) PAFRAC=DT/(PAVE+1.0) WS0=WS0*WS0 IF(RESTART.EQ.'Y')RESTART='y' IF(RADINT.EQ.'Y')RADINT='y' IF(RADINT.EQ.'N')RADINT='n' IF(RADINT.EQ.'n')radcomp=.FALSE. IF(TSINT.EQ.'Y')TSINT='y' IF(TSINT.EQ.'N')TSINT='n' IF(ANRAD.EQ.'Y')ANRAD='y' IF(ANRAD.EQ.'N')ANRAD='n' IF(TDEP.EQ.'Y')TDEP='y' IF(TDEP.EQ.'N')TDEP='n' IF(DDEP.EQ.'Y')DDEP='y' IF(DDEP.EQ.'N')DDEP='n' IF(CALB.EQ.'Y')CALB='y' IF(CALB.EQ.'N')CALB='n' IF(ANRAD.EQ.'y')THEN TDEP='n' DDEP='n' END IF IF(DARAD.EQ.'y')THEN TDEP='n' END IF MONTH0=MONTH IDAY0=IDAY HOUR0=HOUR WFAC=0.0 KQMAX=0 IF(MONTH.EQ.1)THEN JULIENDAY=IDAY ELSE IF(MONTH.EQ.2)THEN JULIENDAY=31+IDAY ELSE IF(MONTH.EQ.3)THEN JULIENDAY=31+28+IDAY ELSE IF(MONTH.EQ.4)THEN JULIENDAY=31+28+31+IDAY ELSE IF(MONTH.EQ.5)THEN JULIENDAY=31+28+31+30+IDAY ELSE IF(MONTH.EQ.6)THEN JULIENDAY=31+28+31+30+31+IDAY ELSE IF(MONTH.EQ.7)THEN JULIENDAY=31+28+31+30+31+30+IDAY ELSE IF(MONTH.EQ.8)THEN JULIENDAY=31+28+31+30+31+30+31+IDAY ELSE IF(MONTH.EQ.9)THEN JULIENDAY=31+28+31+30+31+30+31+31 +IDAY ELSE IF(MONTH.EQ.10)THEN JULIENDAY=31+28+31+30+31+30+31+31+30+IDAY ELSE IF(MONTH.EQ.11)THEN JULIENDAY=31+28+31+30+31+30+31+31+30+31+IDAY ELSE IF(MONTH.EQ.12)THEN JULIENDAY=31+28+31+30+31+30+31+31+30+31+30+IDAY END IF C C Latitude and Corilois parameter C PIM=ACOS(-1.0)/180. DO K=1,NLO RLAT(K)=RLATB+(RLATE-RLATB)*FLOAT(K-1)/FLOAT(NLO-1) FC(K)=1.454E-4*SIN(PIM*RLAT(K)) COSLAT(K)=COS(PIM*RLAT(K)) END DO C C Calculate annual average earth-sun distance, solar zenith angle and albedo C IF(ANRAD.EQ.'y')THEN distm=0.0 do k=1,nlo rmumean(k)=0.0 fracmean(k)=0.0 albmean(k)=0.0 end do DO JDAY=1,365 CALL orbite(FLOAT(JDAY),zlongi,dist) distm=distm+dist do k=2,nlo rlatx=0.5*(RLAT(K)+RLAT(K-1)) CALL angle(zlongi,rlatx,fract,rmu0) CALL alboc(FLOAT(JDAY),rlatx,albsol) rmumean(k)=rmumean(k)+rmu0 fracmean(k)=fracmean(k)+fract albmean(k)=albmean(k)+albsol end do END DO distm=distm/365. do k=2,nlo rmumean(k)=rmumean(k)/365. fracmean(k)=fracmean(k)/365. albmean(k)=albmean(k)/365. end do END IF C C Ocean mixed layer depth and effective soil depth C DO K=1,NLO IF(K.LT.KSOIL)THEN DEPTH(K)=DEPTHR ELSE DEPTH(K)=1.0 END IF END DO C C Soil moisture parameters C TAUSOIL=TAUSOIL*24.*3600. TAURUNOFF=TAURUNOFF*24.*3600. C TAUSOILI=1./TAUSOIL TAURUNOFFI=1./TAURUNOFF IF(TAURUNOFF.GT.100.0)THEN TAURUNOFFI=0.0 END IF C C Read in the initial soundings from the file sounding.in C IF(RESTART.EQ.'y')THEN OPEN(UNIT=9, FILE='output/sounding.out', STATUS='OLD') ELSE OPEN(UNIT=9, FILE='sounding.in', STATUS='OLD') END IF C DO 42 J=2,NLO-1 READ(9,20)NP,TS1(J) 20 FORMAT(T15,I3,T55,F5.2,////) c c TS1(J)=27.5-2.5*TANH(4.*(float(J-10)/FLOAT(NLO-3))) c TS1(J)=TS1(J)+273.15 TS2(J)=TS1(J) DO 40 I=1,NP READ(9,30)P(I),T1(J,I),R1(J,I),O3(I),PSI(J,I),RCOOL(J,I), 1 U1(J,I) 30 FORMAT(3X,F6.1,T12,F8.3,T25,F10.6,T39,F6.3,T47,F6.2, 1 T58,F7.3,T64,F5.1) C C Renormalize certain quantities and produce reverse order arrays for C radiative subroutine C c PSI(J,I)=0.0 c U1(J,I)=0.0 C T1(J,I)=T1(J,I)+273.15 R1(J,I)=0.001*R1(J,I) T2(J,I)=T1(J,I) T0(J,I)=T1(J,I) TMEAN(J,I)=T1(J,I) R2(J,I)=R1(J,I) R0(J,I)=R1(J,I) RMEAN(J,I)=R1(J,I) RCOOL(J,I)=RCOOL(J,I)/(24.*3600.) c PSI(J,I)=0.0 PSI(J,I)=1.0E4*PSI(J,I) IF(P(I).LT.(PFIX+1.0))THEN PSI(J,I+1)=0.0 U1(J,I)=0.0 END IF U2(J,I)=U1(J,I) C IF(J.EQ.(NLO-1))THEN T1(J,I)=T1(J,I)+0.1 T2(J,I)=T1(J,I) END IF C 40 CONTINUE 42 CONTINUE C CLOSE(UNIT=8) CLOSE(UNIT=9) C C Background zonal wind C DO I=1,NP c VZ(I)=20.0*(P(1)-P(I))/(P(1)-500.0) VZ(I)=0.0 VZ(I)=MIN(VZ(I),20.0) c vz(i)=vz(i)+5.0 END DO DO I=2,NP-1 c TX(I)=P(I)*FC(2)*(VZ(I+1)-VZ(I-1))/(287.*(P(I-1)- c 1 P(I+1))) TX(I)=0.0 END DO TX(1)=TX(2) TX(NP)=TX(NP-1) C c TS1(2)=TS1(2)+0./(1.+0.15*9.0) c TS2(2)=TS1(2) C C Surface pressure and surface exchange coefficient C PG=1012.0 CD=1.5E-3 C C Asselin Filter Value C AFILT=0.2 C C Renormalize ozone, define levels C PT=200.0 NPTOP=1 N=1 DO 43 I=1,NP O3(I)=1.0E-6*O3(I) IF(P(I).GE.(PFIX-1.0))NPTOP=MAX(NPTOP,I) IF(P(I).GE.78.0)N=MAX(N,I) IF(I.GT.1)THEN PH(I)=0.5*(P(I)+P(I-1)) PHRAD(NP+2-I)=PH(I) END IF UC(I)=0.0 VC(I)=0.0 TRA1(I,1)=0.0 C C Applied Omega C AOMEGA(I)=4.*AOMEGMAX*(P(1)-P(I))*(P(I)-PT)/ 1 ((P(1)-PT)**2) IF(P(I).LT.PT)AOMEGA(I)=0.0 C C Sponge layer coefficients C SPONGE(I)=SCOEF*(1.-P(I)/85.0) SPONGE(I)=MAX(SPONGE(I),0.0) C 43 CONTINUE C C NPTOP=MIN(NPTOP,NP-1) N=MIN(N,(NP-1)) C PH(1)=2.*P(1)-PH(2) PHRAD(NP+1)=PH(1) PH(NP+1)=2.*PH(NP)-PH(NP-1) PH(NP+1)=MAX(0.1,PH(NP+1)) PHRAD(1)=PH(NP+1) C DPH1I=1.0/(PH(1)-PH(2)) DPHNPI=1.0/(PH(NP)-PH(NP+1)) DP1I=1.0/(P(1)-P(2)) DPNPI=1.0/(P(NP-1)-P(NP)) C C Assign thermodynamic constants C CPD=1005.7 CPV=1870.0 CL=2500.0 RD=287.04 RV=461.5 LV0=2.501E6 G=9.8 ROWL=1000.0 EXPAN=3.2E-4 EPS=RD/RV EPSI=1./EPS CPVMCL=CL-CPV C C Initialize certain quantities and arrays C QSPEED=0.0 DO 45 J=2,NLO-1 FTS(J)=0.0 PSI(J,1)=0.0 ETA1(J,1)=0.0 ETA2(J,1)=0.0 PSI(J,NP)=0.0 ETA1(J,NP)=0.0 ETA2(J,NP)=0.0 RADFLUX(J)=0.0 CBMFA(J)=0.0 C SM1(J)=0.0 SM2(J)=SM1(J) SALB(J)=ALB 45 CONTINUE C DO 60 I=1,NP COOLR(I)=0.0 HEATR(I)=0.0 QCONDT(I)=0.0 CLDF(I)=0.0 CLDQ(I)=0.0 SIGSUB(I)=0.0 RV2M(I)=0.0 CLDFRADM(I)=0.0 CLDEMIM(I)=0.0 CLDTAUM(I)=0.0 DO 51 K=2,NLO-1 UF(K,I)=0.0 IF(I.NE.1.AND.I.NE.NP)THEN ETA1(K,I)=-1.0E-4*((PSI(K,I+1)-PSI(K,I))/(PH(I+1)-PH(I))- 1 (PSI(K,I)-PSI(K,I-1))/(PH(I)-PH(I-1)))/(P(I)-P(I-1)) ETA2(K,I)=ETA1(K,I) END IF ETAF(K,I)=0.0 FTNET(K,I)=0.0 FRNET(K,I)=0.0 FVCNET(K,I)=0.0 MUPGRAPH(K,I)=0.0 MDGRAPH(K,I)=0.0 OLGRAPH(K,I)=0.0 RHGRAPH(K,I)=0.0 ULGRAPH(K,I)=0.0 PSIGRAPH(K,I)=0.0 TEMPGRAPH(K,I)=0.0 AMGRAPH(K,I)=0.0 CAPEGRAPH(K,I)=0.0 CLDTEMP(K,I)=0.0 CLDGRAPH(K,I)=0.0 51 CONTINUE 60 CONTINUE DO 65 K=2,NLO-1 PREBAR(K)=0.0 VBAR(K)=0.0 UBAR(K)=0.0 SSTBAR(K)=0.0 T100BAR(K)=0.0 SWBAR(K)=0.0 CAPEBAR(K)=0.0 QRBAR(K)=0.0 OLRBAR(K)=0.0 LCBAR(K)=0.0 HCBAR(K)=0.0 EFBAR(K)=0.0 65 CONTINUE DO K=1,NLO AFLUXGRAPH(K)=0.0 OFLUXGRAPH(K)=0.0 NETFLUXGRAPH(K)=0.0 AFLUX(K)=0.0 OFLUX(K)=0.0 VOCEAN(K)=0.0 NETFLUX(K)=0.0 VMAXK(K)=0.0 FS(K)=0.0 FL(K)=0.0 END DO IF((ICLOUD.EQ.'n'.OR.IVAPOR.EQ.'n').AND.FWRITE.NE.'y')THEN OPEN(10,FILE='output/variables',form='unformatted', 1 status='unknown') READ(10) RV2M,CLDFRADM,CLDEMIM,CLDTAUM CLOSE(10) END IF C C Initialize counters C TIME=HOUR*3600. RADTIME=0.0 PRINTIME=0.0 NT=0 NPR=1 NPRINT=0 TPERR=0.0 OLRERR=0. ASRERR=0. OLRBIA=0. ASRBIA=0. OLRNB=0. ASRNB=0. NRHI=0 NTPI=0 RHERRI=0. TPERRI=0. NSAVE=0 NPRIRAD=0 C C Begin time loop at next statement C 100 CONTINUE C TIME=TIME+DT RADTIME=RADTIME+DT PRINTIME=PRINTIME+DT NT=NT+1 IF(TIME.GT.ENDTIME)GOTO 200 NPRINT=NPRINT+1 c IF(TIME.GT.(50.*24.*3600.))CD=0.0 C c Relate evaporative fraction to soil moisture c DO I=1,NLO-1 IF(I.LT.KSOIL)THEN EFRAC(I)=1.0 ELSE IF(ISOIL.EQ.'y')THEN EFRAC(I)=0.5*(1.+TANH(SBETA*SM2(I))) ELSE EFRAC(I)=EFRACR END IF END IF END DO C C *** Boundary values *** C IF(BCS.EQ.'p')THEN c TS1(1)=TS1(NLO-1) TS2(1)=TS2(NLO-1) TS1(NLO)=TS1(2) TS2(NLO)=TS2(2) SM1(1)=SM1(NLO-1) SM2(1)=SM2(NLO-1) SM1(NLO)=SM1(1) SM2(NLO)=SM2(2) DO 105 I=1,NP U1(1,I)=U1(NLO-1,I) U2(1,I)=U2(NLO-1,I) U1(NLO,I)=U1(2,I) U2(NLO,I)=U2(2,I) T1(1,I)=T1(NLO-1,I) T2(1,I)=T2(NLO-1,I) T1(NLO,I)=T1(2,I) T2(NLO,I)=T2(2,I) R1(1,I)=R1(NLO-1,I) R2(1,I)=R2(NLO-1,I) R1(NLO,I)=R1(2,I) R2(NLO,I)=R2(2,I) c c if(p(i).gt.620.0)then c r1(1,i)=0.004 c r2(1,i)=0.004 c else if(p(i).gt.240.and.p(i).le.620.)then c r1(1,i)=0.0002*(p(i)-200.)/620. c r2(1,i)=0.0002*(p(i)-200.)/620. c else c r1(1,i)=2.0e-6 c r2(1,i)=2.0e-6 c end if c r1(nlo,i)=r1(nlo-1,i) c r2(nlo,i)=r2(nlo-1,i) c PSI(1,I)=PSI(NLO-1,I) PSI(NLO,I)=PSI(2,I) ETA1(1,I)=ETA1(NLO-1,I) ETA1(NLO,I)=ETA1(2,I) FVCNET(1,I)=FVCNET(NLO-1,I) FVCNET(NLO,I)=FVCNET(2,I) 105 CONTINUE C ELSE C TS1(1)=TS1(2) TS2(1)=TS2(2) TS1(NLO)=TS1(NLO-1) TS2(NLO)=TS2(NLO-1) SM1(1)=SM1(2) SM2(1)=SM2(2) SM1(NLO)=SM1(NLO-1) SM2(NLO)=SM2(NLO-1) DO 106 I=1,NP U1(1,I)=0.0 U2(1,I)=0.0 U1(NLO,I)=0.0 U2(NLO,I)=0.0 T1(1,I)=T1(2,I) T2(1,I)=T2(2,I) T1(NLO,I)=T1(NLO-1,I) T2(NLO,I)=T2(NLO-1,I) R1(1,I)=R1(2,I) R2(1,I)=R2(2,I) R1(NLO,I)=R1(NLO-1,I) R2(NLO,I)=R2(NLO-1,I) PSI(1,I)=0.0 PSI(NLO,I)=0.0 ETA1(1,I)=0.0 ETA1(NLO,I)=0.0 PSI(NLO-1,I)=0.0 ETA1(NLO-1,I)=0.0 FVCNET(1,I)=FVCNET(2,I) FVCNET(NLO,I)=FVCNET(NLO-1,I) 106 CONTINUE C END IF SUMFLUX=0.0 DELTGLOBAL=(ABS(TS2(1)-TS2(NLO)))**(1./3) DELTGLOBAL=MAX(DELTGLOBAL,1.0) C DO 155 K=2,NLO-1 C COSLATBAR=0.5*(COSLAT(K)+COSLAT(K-1)) COSLATBARI=1./COSLATBAR FCBAR=0.5*(FC(K)+FC(K-1)) FTS(K)=0.0 IF(TDEP.EQ.'y')THEN XT=TIME/(3600.*24.)+HOUR0/24. HOUR=24.*(XT-AINT(XT)) END IF IF(DDEP.EQ.'y'.OR.DDEP.EQ.'Y')THEN XT=TIME/(3600.*24.)+FLOAT(IDAY0)+30.*FLOAT(MONTH0-1)+ 1 HOUR0/24. DAY=XT-365.*AINT(XT/365.) AMON=1.1+AINT((DAY-1.)/30.) AMON=MIN(12.1,AMON) MONTH=AMON MONTH=MAX(MONTH,1) IDAY=DAY-30.*FLOAT(MONTH-1) END IF C C Calculate saturation specific humidity and some temporary arrays C TC=TS1(K)-273.15 ES=6.112*EXP(17.67*TC/(243.5+TC)) RSS=0.98*EPS*ES/(PG-(1.-EPS)*ES) PRADJ=0.0 TG=TS1(K) RG=RSS C DO 110 I=1,NP FTNET(K,I)=0.0 FRNET(K,I)=0.0 TC=T2(K,I)-273.15 IF(TC.GE.0.0)THEN ES=6.112*EXP(17.67*TC/(243.5+TC)) ELSE ES=EXP(23.33086-6111.72784/T2(K,I)+0.15215*LOG(T2(K,I))) END IF ES=MIN(ES,P(I)) RS(I)=EPS*ES/(P(I)-(1.-EPS)*ES) TTEMP(I)=T2(K,I) RTEMP(I)=R2(K,I) TCONV(I)=T2(K,I) RCONV(I)=R2(K,I) UC(I)=U2(K,I) C 110 CONTINUE C DO I=1,NP-1 VC(I)=0.005*(PSI(K-1,I+1)-PSI(K-1,I)+PSI(K,I+1)-PSI(K,I))/ 1 (PH(I)-PH(I+1))+VZ(I) VCO(I)=VC(I) UCO(I)=UC(I) END DO C CBMF=CBMFA(K) C C Call convection subroutine C CALL CONVECT(TCONV,RCONV,RS,UC,VC,TRA1,P,PH,NA,N,0,DT,IFLAG,FT,FR, 1 FUC,FVC,FTRA,PRECIP,WD,TPRIME,QPRIME,QCONDT,CBMF,FS(K),FL(K)) C C If necessary, write to error file C IF(IFLAG.EQ.4)THEN WRITE(11,120)NT 120 FORMAT(5X,'CFL condition violated at time step ',I8) END IF C C Store convective momentum flux for vorticity calculation C DO I=1,N FVCNET(K,I)=FVC(I)+(VC(I)-VCO(I))/(0.5*3600.) FUC(I)=FUC(I)+(UC(I)-UCO(I))/(0.5*3600.) END DO C PREBAR(K)=PREBAR(K)+PRECIP CAPEBAR(K)=CAPEBAR(K)+CAPEM QRBAR(K)=QRBAR(K)+RCONV(1) OBAR(K)=OBAR(K)+36.*(COSLAT(K)*PSI(K,9)- 1 COSLAT(K-1)*PSI(K-1,9))*DXI*COSLATBARI VBAR(K)=VBAR(K)+0.01*PSI(K,2)*DPH1I UBAR(K)=UBAR(K)+U2(K,1) SSTBAR(K)=SSTBAR(K)+TS2(K)-273.15 EFBAR(K)=EFBAR(K)+EFRAC(K) T100BAR(K)=T100BAR(K)+T2(K,37)-273.15 C C Add convective tendencies to net tendencies C IF(K.EQ.2)INBA=INB RINB=MIN(R1(1,INBA),8.0E-5) DO 125 I=1,N FTNET(K,I)=FTNET(K,I)+FT(I) FRNET(K,I)=FRNET(K,I)+FR(I) R2(K,I)=RCONV(I) T2(K,I)=TCONV(I) 125 CONTINUE CBMFA(K)=CBMF C C *** Relax water vapor above tropopause to tropopause value *** C DO 126 I=INB+1,NP FRNET(K,I)=FRNET(K,I)+2.0E-6*(0.4*RS(I)*P(I)/P(INB+1)-R1(K,I)) 126 CONTINUE C C -- sb: C ------------------------------------------------------------------- C C Compute the cloud fraction and the cloud water content: C C 1) make supersaturation adjustment C (precipitate only a fraction of the supersaturation) C C 2) compute the cloud fraction using the in-cloud water C content derived from the convection scheme (the subgrid-scale C part of the in-cloud water) and that derived from the C large-scale condensation scheme (or supersaturation sdjustment). C C ------------------------------------------------------------------- C CALL CLOUDS_SUB_LS_40(NP,RCONV,RS,TCONV,P,PH,DT,qcondt : ,CLDF,CLDQ,PRADJ,FTADJ,FRADJ,SIGSUB) C C Add tendencies due to supersaturation adjustment: C DO 111 I = 1, NP C FRNET(K,I)=FRNET(K,I)+FRADJ(I) FTNET(K,I)=FTNET(K,I)+FTADJ(I) C 111 CONTINUE C C Add precip from supersaturation adjustment to convective precip: C PREBAR(K)=PREBAR(K)+PRADJ C C ------------------------------------------------------------------- C C Compute cloud optical properties: C C ------------------------------------------------------------------- c pressure: mb -> Pa: DO I = 1, NP paprs(I) = PH(I)*100. pplay(I) = P(I)*100. ENDDO paprs(NP+1) = PH(NP+1)*100. c IF(ICLOUD.EQ.'n')THEN DO I=1,NP CLDF(I)=CLDFRADM(I) END DO END IF c AHCSUM=1.0 ALCSUM=1.0 DO I = 1, NP CLDFRAD(I) = CLDF(I) CLDTEMP(K,I)=CLDF(I) CLDQRAD(I) = CLDQ(I) IF(P(I).GT.522.0)THEN ALCSUM=ALCSUM*(1.-CLDF(I)) ELSE AHCSUM=AHCSUM*(1.-CLDF(I)) END IF ENDDO LCBAR(K)=LCBAR(K)+1.-ALCSUM HCBAR(K)=HCBAR(K)+1.-AHCSUM C CALL OPTICAL(NP,TCONV,paprs,pplay,CLDFRAD,CLDQRAD : ,CLDEMI,CLDTAU,CLDFICE,CLDT,CLDWP) C ------------------------------------------------------------------- C C Prepare and call radiation: C C ------------------------------------------------------------------- C IF(RADINT.EQ.'y')THEN IF(TIME.LT.(1.5*DT).OR.RADTIME.GT.(RADFREQ-10.0))THEN IF(K.EQ.(NLO-1))RADTIME=0.0 c c -- local hour (RLON=longitude): c RLON=RLONB+(RLONE-RLONB)*FLOAT(K-1)/FLOAT(NLO-1) TIMEL = TIME + RLON/360.*24.*3600. C C -- Use annual means, if specified: C IF(ANRAD.EQ.'y')THEN dist=distm rmu0=rmumean(k) fract=fracmean(k) albsol=albmean(k) ELSE c c -- Earth-Sun distance: c IF(DDEP.EQ.'y')THEN IF(TDEP.EQ.'n')THEN julien = JULIENDAY + INT(TIMEL)/(3600*24) rjulien=float(julien) ELSE rjulien=float(julienday)+timel/(3600.*24.) END IF ELSEIF(TDEP.EQ.'y')THEN rjulien=float(julienday)+timel/(3600.*24.)- 1 INT(timel/(3600.*24.)) ELSE julien = JULIENDAY rjulien=float(julien) END IF c CALL orbite(rjulien,zlongi,dist) c -- solar zenith angle and surface albedo: c RLATX=0.5*(RLAT(K)+RLAT(K-1)) IF(DARAD.EQ.'y')THEN ! no diurnal cycle CALL angle(zlongi,RLATX,fract,rmu0) c print*, rlatx, fract CALL alboc(rjulien,RLATX,albsol) ELSE IF(TDEP.EQ.'y')THEN gmtime = MOD(TIME,3600.*24.)/86400. - 0.5*RADFREQ/86400. CALL zenang(zlongi,gmtime,RADFREQ,RLATX,RLON,rmu0,fract) ELSE gmtime=HOUR/24.-0.05 CALL zenang(zlongi,gmtime,0.1,RLATX,RLON,rmu0,fract) END IF CALL alboc_cd(rmu0,albsol) ENDIF C END IF c c -- call radiation: IF(CALB.EQ.'n'.AND.K.LT.KSOIL)albsol=ALB IF(K.GE.KSOIL)albsol=ALBLAND DO I = 1, NP RV2(I) = RCONV(I) - CLDQ(I)*CLDF(I) RV2(I) = MAX( MIN(RV2(I),RCONV(I)) , 0.0 ) TMEAN(K,I)=T2(K,I) RMEAN(K,I)=R2(K,I) ENDDO C IF(FWRITE.EQ.'y')THEN NSAVE=NSAVE+1 DO I=1,NP RV2M(I)=RV2M(I)+RV2(I) CLDFRADM(I)=CLDFRADM(I)+CLDFRAD(I) CLDEMIM(I)=CLDEMIM(I)+CLDEMI(I) CLDTAUM(I)=CLDTAUM(I)+CLDTAU(I) END DO END IF IF(ICLOUD.EQ.'n')THEN DO I=1,NP CLDFRAD(I)=CLDFRADM(I) CLDEMI(I)=CLDEMIM(I) CLDTAU(I)=CLDTAUM(I) END DO END IF IF(IVAPOR.EQ.'n')THEN DO I=1,NP RV2(I)=MIN(RV2M(I),RS(I)) END DO END IF C TG=TS2(K) C CALL radlwsw e (dist, rmu0, fract, CO2, SCON, e paprs, pplay,TG,albsol,TCONV,RV2,O3, e CLDFRAD, CLDEMI, CLDTAU, s heat,heat0,cool,cool0,radsol,albpla, s topsw,toplw,solsw,sollw, s topsw0,toplw0,solsw0,sollw0) C C Calculate net radiative cooling rate C SWBAR(K)=SWBAR(K)+solsw OLRBAR(K)=OLRBAR(K)+toplw IF(K.EQ.2)NPRIRAD=NPRIRAD+1 RADFLUX(K)=radsol NETFLUX(K)=NETFLUX(K-1)+COSLATBAR*DX*(topsw-toplw) radsoln=radsol c radsoln=solsw+sollw DO 130 I=1,NP RCOTN(K,I)=(cool(I)-heat(I))/(24.*3600.) RCLW(I)=cool0(I)-cool(I) ! diagnostic only RCSW(I)=heat(I)-heat0(I) ! diagnostic only c thermo constants used in Morcrette's radiation are different from those c used in the calling program, so we renormalize the cooling rates: RCOTN(K,I)=RCOTN(K,I)*1004.709/(CPD*(1.-RCONV(I))+ 1 CPV*RCONV(I)) RCOTN(K,I)=RCOTN(K,I)*G/9.80665 130 CONTINUE c if (radcomp) rad1st = .TRUE. c END IF END IF C sb -- C C Add radiative cooling to net heating rate C DO 135 I=1,NP if (RADINT.EQ.'y') then FTNET(K,I)=FTNET(K,I)-RCOTN(K,I) RCOOL(K,I)=RCOTN(K,I) FTNET(K,I)=FTNET(K,I)-RDAMP*(T1(K,I)-TMEAN(K,I)) FRNET(K,I)=FRNET(K,I)-RDAMP*(R1(K,I)-RMEAN(K,I)) else IF(P(I).GT.95.0)THEN c -- sb: cc FTNET(I)=FTNET(I)-RCOT cc RCOOL(I)=RCOT c FTNET(I)=FTNET(I)-RCOTU(I) FTNET(K,I)=FTNET(K,I)-RCOOL(K,I) c RCOOL(I)=RCOTU(I) c sb -- ELSE RCOOL(K,I)=0.0 END IF endif ! radcomp 135 CONTINUE C C Calculate surface flux forcing C TSA=T1(K,1)*(PG/P(1))**(RD/CPD) ROWS=PG/(RD*TSA*(1.+R2(K,1)*(EPSI-1.))) IF(WDEP.EQ.'y'.OR.WDEP.EQ.'Y')THEN VS=VS0+0.005*(PSI(K,2)+PSI(K-1,2))*DPH1I VSB=VS0+0.01*PSI(K,2)*DPH1I US=US0+U1(K,1) USB=0.5*(U1(K,1)+U1(K+1,1)) VSURF=SQRT(WS0+WD*WD+VS*VS+US*US) VSURFB=SQRT(WS0+WD*WD+VSB*VSB+USB*USB) VSPRIME=VSURF-SQRT(WS0+VS*VS+US*US) ELSE VSURF=SQRT(WS0+WD*WD+VS0*VS0+US0*US0) VSPRIME=VSURF-SQRT(WS0+VS0*VS0+US0*US0) VSURFB=VSURF END IF C FTSURF=G*ROWS*CD*(VSURF*(TS1(K)-TSA)-VSPRIME*TPRIME) 1 *DPH1I FTNET(K,1)=FTNET(K,1)+FTSURF FRSURF=G*ROWS*CD*(VSURF*(RSS-R1(K,1))-VSPRIME*QPRIME) 1 *EFRAC(K)*DPH1I FRNET(K,1)=FRNET(K,1)+FRSURF C FSOIL(K)=0.0 IF(ISOIL.EQ.'y')THEN FRSURFM=100.*3600.*24.*FRSURF/(G*DPH1I) FSOIL(K)=TAUSOILI*(PRECIP+PRADJ-FRSURFM)-TAURUNOFFI*SM1(K) END IF FS(K)=100.*ROWS*CD*CPD*(VSURF*(TS1(K)-TSA)-VSPRIME*TPRIME) FL(K)=100.*2.5E6*ROWS*CD*(VSURF*(RSS-R1(K,1))-VSPRIME*QPRIME) FL(K)=FL(K)*EFRAC(K) C C Put values into time arrays C IF(PRINTIME.GT.(PRINFREQ-10.0))THEN ANPRI=1./FLOAT(NPRINT) ANPRIRADI=1./FLOAT(NPRIRAD) PGRAPH(K,NPR)=PREBAR(K)*ANPRI CAPEGRAPH(K,NPR)=287.*CAPEBAR(K)*ANPRI QRGRAPH(K,NPR)=1000.*QRBAR(K)*ANPRI OGRAPH(K,NPR)=OBAR(K)*ANPRI VGRAPH(K,NPR)=VBAR(K)*ANPRI UTGRAPH(K,NPR)=UBAR(K)*ANPRI SSTGRAPH(K,NPR)=SSTBAR(K)*ANPRI EFRACGRAPH(K,NPR)=EFBAR(K)*ANPRI T100GRAPH(K,NPR)=T100BAR(K)*ANPRI SWGRAPH(K,NPR)=SWBAR(K)*ANPRIRADI OLRGRAPH(K,NPR)=OLRBAR(K)*ANPRIRADI HCGRAPH(K,NPR)=HCBAR(K)*ANPRIRADI LCGRAPH(K,NPR)=LCBAR(K)*ANPRIRADI HCGRAPH(K,NPR)=MIN(HCGRAPH(K,NPR),1.0) LCGRAPH(K,NPR)=MIN(LCGRAPH(K,NPR),1.0) C PREBAR(K)=0.0 CAPEBAR(K)=0.0 QRBAR(K)=0.0 OBAR(K)=0.0 VBAR(K)=0.0 UBAR(K)=0.0 SSTBAR(K)=0.0 EFBAR(K)=0.0 T100BAR(K)=0.0 SWBAR(K)=0.0 OLRBAR(K)=0.0 HCBAR(K)=0.0 LCBAR(K)=0.0 C SST=TS2(K)-273.15 VMAXK(K)=0.0 MPIGRAPH(K,NPR)=0.0 IF(K.LT.KSOIL)THEN CALL PCMIN(SST,PG,P,TCONV,RCONV,NA,N,PMIN,VMAX,IFL) MPIGRAPH(K,NPR)=VMAX VMAXK(K)=VMAX END IF C IF(K.EQ.(NLO-1))THEN GTIME(NPR)=TIME/(3600.*24.) NPR=NPR+1 PRINTIME=0.0 NPRINT=0 NPRIRAD=0 END IF END IF C C Calculate forcing of surface temperature C IF(TSINT.EQ.'y'.OR.TSINT.EQ.'Y')THEN TC=TS1(K)-273.15 ALV=(LV0-CPVMCL*TC)*EFRAC(K) SFLUX=(CPD*(1.-R1(K,1))+CPV*R1(K,1))*100.0*ROWS*CD*(VSURF* 1 (TS1(K)-TSA)-VSPRIME*TPRIME)+ 2 ALV*100.0*ROWS*CD*(VSURF*(RSS-R1(K,1))-VSPRIME*QPRIME) C C Calculate entrainment and ocean current speed and add to ocean heat budget C DELSST=(TS1(K)-TS1(NLO)) DELSST=MAX(DELSST,0.0) C WEH=CCOUP*1.0E-7*SQRT(10.0/(0.1+DELSST))*(VMAXK(K)/70.)**6 C IF(K.LT.(NLO-1))THEN VOCEAN(K)=(VOCEAN(K-1)*COSLAT(K-1)+WEH*DX*COSLATBAR)/COSLAT(K) END IF C FTS(K)=FTS(K)-DELSST*WEH+VOCEAN(K-1)*(TS1(K-1)-TS1(K))/DX C OFLUX(K)=ROWL*4190.0*DEPTH(K)*VOCEAN(K)*DELSST*COSLATBAR C C If radiative cooling is specified, calculate net surface radiative C flux that is consistent with vertically integrated cooling C IF(RADINT.EQ.'y')THEN FTS(K)=FTS(K)+(RADFLUX(K)-SFLUX)/(DEPTH(K)*ROWL*CL) ELSE RADFLC=0.0 DO I=1,NP RADFLC=RADFLC+(CPD*(1.-RCONV(I))+CPV*RCONV(I))*RCOOL(K,I)* 1 100.*(PH(I)-PH(I+1))/G END DO FTS(K)=FTS(K)+(RADFLC-SFLUX)/(DEPTH(K)*ROWL*CL) END IF END IF C C Calculate atmospheric forcings and add to net tendencies C C Level 1 forcings C C Advections: C VOMEG=(COSLAT(K)*PSI(K,2)-COSLAT(K-1)*PSI(K-1,2))*DXI*COSLATBARI+ 1 AOMEGA(2) VVP=0.01*MAX(VOMEG,0.0) VAM=0.01*PSI(K-1,2)*DPH1I+VZ(1) VAP=0.01*PSI(K,2)*DPH1I+VZ(1) VAM=MAX(VAM,0.0) VAP=MIN(VAP,0.0) VA=0.005*(PSI(K-1,2)+PSI(K,2))*DPH1I ALPHA=RD*T2(K,1)*(1.+R2(K,1)*(EPSI-1.))/P(1) C FTADV=VVP*ALPHA/CPD-VVP*(T2(K,1)-T2(K,2))*DP1I FRADV=-VVP*(R2(K,1)-R2(K,2))*DP1I FUADV=-VVP*(U2(K,1)-U2(K,2))*DP1I FTHADV=-(VAM*(T2(K,1)-T2(K-1,1))+VAP*(T2(K+1,1)-T2(K,1)))*DXI FRHADV=-(VAM*(R2(K,1)-R2(K-1,1))+VAP*(R2(K+1,1)-R2(K,1)))*DXI FUHADV=-(VAM*(U2(K,1)-U2(K-1,1))+VAP*(U2(K+1,1)-U2(K,1)))*DXI C AFLUX(K)=PSI(K,2)*0.5*(CPD*(T2(K+1,1)+T2(K,1))+LV0* C 1 (R2(K+1,1)+R2(K,1))) AFLUX(K)=-(CPD*(FTHADV+FTADV)+LV0*(FRHADV+FRADV))* 1 (PH(1)-PH(2)) C UF(K,1)=VA*FCBAR+FUADV+FUHADV+FUC(1) c UF(K,1)=0.0 ETAF(K,1)=0.0 FTUADV=-U2(K,1)*TX(1) FRUADV=5423.0*R1(K,1)*FTUADV/(T2(K,1)*T2(K,1)) FTNET(K,1)=FTNET(K,1)+FTADV+FTHADV+FTUADV FRNET(K,1)=FRNET(K,1)+FRADV+FRHADV+FRUADV C C Level 1 Vertical diffusion terms C PNUP=PNUM*(P(2)-P(1)+DPBL)/DPBL PNUP=MAX(PNUP,0.0) c TAUETA0=CD*VSURFB*ETA1(K,1)*ROWS*G TAUETA0=-CD*VSURFB*PSI(K,2)*1.0E-4*ROWS*G*DPH1I*DPH1I DIFETA=2.*PNUP*(ETA1(K,2)-ETA1(K,1))-TAUETA0*DPH1I C PNUP=PNUM*(PH(2)-PH(1)+DPBL)/DPBL PNUP=MAX(PNUP,0.0) TAUU0=CD*VSURF*(U1(K,1)+US0)*ROWS*G DIFU=2.*PNUP*(U1(K,2)-U1(K,1))-TAUU0*DP1I C ETAF(K,1)=ETAF(K,1)+DIFETA ETAF(K,2)=DIFETA UF(K,1)=UF(K,1)+DIFU C C Level 1 Horizontal diffusion terms C DIFHU=2.*DAMP*(U1(K+1,1)*COSLAT(K+1)+U1(K-1,1)*COSLAT(K-1)- 1 2.*U1(K,1)*COSLAT(K))/COSLAT(K) DIFHT=2.*DAMP*(T1(K+1,1)+T1(K-1,1)-2.*T1(K,1)) DIFHR=2.*DAMP*(R1(K+1,1)+R1(K-1,1)-2.*R1(K,1)) AFLUX(K)=AFLUX(K)-DIFHT*CPD*(PH(1)-PH(2)) C UF(K,1)=UF(K,1)+DIFHU FTNET(K,1)=FTNET(K,1)+DIFHT FRNET(K,1)=FRNET(K,1)+DIFHR GZ1=0.0 GZ2=0.0 C C Interior forcings C DO 140 I=2, NP-1 C C Advections: C VOMEG1=(COSLAT(K)*PSI(K,I+1)-COSLAT(K-1)*PSI(K-1,I+1))*DXI* 1 COSLATBARI+AOMEGA(I+1) VOMEG=(COSLAT(K)*PSI(K,I)-COSLAT(K-1)*PSI(K-1,I))*DXI* 1 COSLATBARI+AOMEGA(I) VVP=0.01*MAX(VOMEG1,0.0) VVM=0.01*MIN(VOMEG,0.0) ALPHA=RD*T2(K,I)*(1.+R2(K,I)*(EPSI-1.))/P(I) VAM=0.01*(PSI(K-1,I+1)-PSI(K-1,I))/(PH(I)-PH(I+1))+VZ(I) VAP=0.01*(PSI(K,I+1)-PSI(K,I))/(PH(I)-PH(I+1))+VZ(I) VA=0.5*(VAM+VAP)-VZ(I) VAM=MAX(VAM,0.0) VAP=MIN(VAP,0.0) C VA=VAP+VAM FTADV=(VVP+VVM)*ALPHA/CPD- 1 VVP*(T2(K,I)-T2(K,I+1))/(P(I)-P(I+1))- 2 VVM*(T2(K,I-1)-T2(K,I))/(P(I-1)-P(I)) FRADV=-VVP*(R2(K,I)-R2(K,I+1))/(P(I)-P(I+1))- 1 VVM*(R2(K,I-1)-R2(K,I))/(P(I-1)-P(I)) FUADV=-VVP*(U2(K,I)-U2(K,I+1))/(P(I)-P(I+1))- 1 VVM*(U2(K,I-1)-U2(K,I))/(P(I-1)-P(I)) FTHADV=-(VAM*(T2(K,I)-T2(K-1,I))+VAP*(T2(K+1,I)-T2(K,I)))*DXI FRHADV=-(VAM*(R2(K,I)-R2(K-1,I))+VAP*(R2(K+1,I)-R2(K,I)))*DXI FUHADV=-(VAM*(U2(K,I)-U2(K-1,I))+VAP*(U2(K+1,I)-U2(K,I)))*DXI C UF(K,I)=VA*FCBAR+FUADV+FUHADV+FUC(I) c UF(K,I)=0.0 FTUADV=-U2(K,I)*TX(I) FRUADV=5423.0*R1(K,I)*FTUADV/(T2(K,I)*T2(K,I)) C FTNET(K,I)=FTNET(K,I)+FTADV+FTHADV+FTUADV FRNET(K,I)=FRNET(K,I)+FRADV+FRHADV+FRUADV AFLUX(K)=AFLUX(K)-(CPD*(FTHADV+FTADV)+LV0*(FRHADV+FRADV))* 1 (PH(I)-PH(I+1)) C C Calculate forcing of horizontal vorticity C TVDIF1=T2(K+1,I)*(1.+R2(K+1,I)*(EPSI-1.))- 1 T2(K,I)*(1.+R2(K,I)*(EPSI-1.)) TVDIF2=T2(K+1,I-1)*(1.+R2(K+1,I-1)*(EPSI-1.))- 1 T2(K,I-1)*(1.+R2(K,I-1)*(EPSI-1.)) ETAF(K,I)=0.005*RD*DXI*(TVDIF1/PH(I)+TVDIF2/PH(I-1)) ETAF(K,I)=ETAF(K,I)-FC(K)*0.005*(U2(K,I-1)+U2(K+1,I-1)- 1 U2(K,I)-U2(K+1,I))/(P(I-1)-P(I)) C C Convective momentum flux forcing of vorticity C ETAF(K-1,I)=ETAF(K-1,I)+0.005*(FVCNET(K,I-1)-FVCNET(K,I)+ 1 FVCNET(K-1,I-1)-FVCNET(K-1,I))/(PH(I-1)-PH(I)) C C Advection of vorticity by horizontal flow C VAM=0.5*(VZ(I-1)+VZ(I))+0.005*(PSI(K,I+1)-PSI(K,I-1)+ 1 PSI(K-1,I+1)-PSI(K-1,I-1))/(PH(I-1)-PH(I+1)) VAP=0.5*(VZ(I-1)+VZ(I))+0.005*(PSI(K,I+1)-PSI(K,I-1)+ 1 PSI(K+1,I+1)-PSI(K+1,I-1))/(PH(I-1)-PH(I+1)) VAM=MAX(VAM,0.0) VAP=MIN(VAP,0.0) ETAF(K,I)=ETAF(K,I)-(VAM*(ETA2(K,I)- 1 ETA2(K-1,I))+VAP*(ETA2(K+1,I)-ETA2(K,I)))*DXI C C Vertical diffusion terms C PNU=PNUM*(P(I)-P(1)+DPBL)/DPBL PNU=MAX(PNU,0.0) PNUP=PNUM*(P(I+1)-P(1)+DPBL)/DPBL PNUP=MAX(PNUP,0.0) DIFETA=(PH(I-1)-PH(I+1))*(PNUP*(ETA1(K,I+1)-ETA1(K,I))/ 1 (PH(I)-PH(I+1))-PNU*(ETA1(K,I)-ETA1(K,I-1))/ 2 (PH(I-1)-PH(I))) C PNU=PNUM*(PH(I)-PH(1)+DPBL)/DPBL PNU=MAX(PNU,0.0) PNUP=PNUM*(PH(I+1)-PH(1)+DPBL)/DPBL PNUP=MAX(PNUP,0.0) DIFU=(P(I-1)-P(I+1))*(PNUP*(U1(K,I+1)-U1(K,I))/ 1 (P(I)-P(I+1))-PNU*(U1(K,I)-U1(K,I-1))/(P(I-1)-P(I))) c DIFU=10.*DIFU C ETAF(K,I)=ETAF(K,I)+DIFETA UF(K,I)=UF(K,I)+DIFU C C Horizontal diffusion terms C DIFHETA=2.*DAMP*(ETA1(K+1,I)+ETA1(K-1,I)-2.*ETA1(K,I)) DIFHU=2.*DAMP*(U1(K+1,I)*COSLAT(K+1)+U1(K-1,I)*COSLAT(K-1)- 1 2.*U1(K,I)*COSLAT(K))/COSLAT(K) DIFHT=2.*DAMP*(T1(K+1,I)+T1(K-1,I)-2.*T1(K,I)) DIFHR=2.*DAMP*(R1(K+1,I)+R1(K-1,I)-2.*R1(K,I)) c DIFHT=0.0 c DIFHR=0.0 AFLUX(K)=AFLUX(K)-DIFHT*CPD*(PH(I)-PH(I+1)) C ETAF(K,I)=ETAF(K,I)+DIFHETA UF(K,I)=UF(K,I)+DIFHU FTNET(K,I)=FTNET(K,I)+DIFHT FRNET(K,I)=FRNET(K,I)+DIFHR C C Sponge layer damping C FTNET(K,I)=FTNET(K,I)+SPONGE(I)*(T0(K,I)-T1(K,I)) FRNET(K,I)=FRNET(K,I)+SPONGE(I)*(R0(K,I)-R1(K,I)) UF(K,I)=UF(K,I)-SPONGE(I)*U1(K,I) ETAF(K,I)=ETAF(K,I)-SPONGE(I)*ETA1(K,I) C C IF(I.GE.NPTOP)THEN C ETAF(K,I)=0.0 C UF(K,I)=0.0 C END IF C 140 CONTINUE AFLUX(K)=AFLUX(K-1)+AFLUX(K)*100.*DX*COSLATBAR/G C C Level NP forcings C UF(K,NP)=0.0 C C Calculate certain graphics quantities C DO 150 I=1,NP MUPG(K,I)=1000.*MUP(I) MDG(K,I)=-1000.*MP(I) RHG(K,I)=100.*R2(K,I)/(RS(I)+2.0E-6) RHG(K,I)=MIN(RHG(K,I),100.0) RHG(K,I)=MAX(RHG(K,I),0.0) OLG(K,I)=36.*(COSLAT(K)*PSI(K,I)-COSLAT(K-1)*PSI(K-1,I))* 1 DXI*COSLATBARI 150 CONTINUE C 155 CONTINUE OFLUX(NLO-1)=0.0 AFLUX(NLO-1)=0.0 C DO I=2,NP-1 ETAF(NLO-1,I)=ETAF(NLO-1,I)+0.005*(FVCNET(NLO-1,I-1)- 1 FVCNET(NLO-1,I)+FVCNET(NLO-2,I-1)-FVCNET(NLO-2,I))/ 2 (PH(I-1)-PH(I)) END DO C DO I=1,NP RHG(1,I)=RHG(NLO-1,I) RHG(NLO,I)=RHG(2,I) END DO C C Calculate moving average plots C IF(TIME.GT.(ENDTIME-PAVE))THEN AFLEN=2.*3.14159*6.38E6*1.0E-15*PAFRAC DO K=2,NLO-1 AFLUXGRAPH(K)=AFLUXGRAPH(K)+AFLUX(K)*AFLEN OFLUXGRAPH(K)=OFLUXGRAPH(K)+OFLUX(K)*AFLEN NETFLUXGRAPH(K)=NETFLUXGRAPH(K)+NETFLUX(K)*AFLEN END DO DO 203 I=1,NP DO 203 K=2,NLO-1 J=K+(VTRANS*TIME*DXI) IF(VTRANS.GE.0.0)THEN J=J-(NLO-2)*(J/NLO) ELSE J=J+(NLO-1)*((NLO-J)/NLO) END IF OLGRAPH(K,I)=OLGRAPH(K,I)+OLG(J,I)*PAFRAC MUPGRAPH(K,I)=MUPGRAPH(K,I)+MUPG(J,I)*PAFRAC MDGRAPH(K,I)=MDGRAPH(K,I)+MDG(J,I)*PAFRAC RHGRAPH(K,I)=RHGRAPH(K,I)+RHG(J,I)*PAFRAC ULGRAPH(K,I)=ULGRAPH(K,I)+U2(J,I)*PAFRAC PSIGRAPH(K,I)=PSIGRAPH(K,I)+1.0E-5*PSI(J,I)* 1 COS(PIM*RLAT(J))*PAFRAC TEMPGRAPH(K,I)=TEMPGRAPH(K,I)+T2(J,I)*PAFRAC TEMPGRAPHNET(K,I)=TEMPGRAPH(K,I) AMGRAPH(K,I)=AMGRAPH(K,I)+(U2(J,I)+ 1 1.454E-4*6.38E6*COS(PIM*0.5*(RLAT(J)+RLAT(J-1))))* 2 PAFRAC CLDGRAPH(K,I)=CLDGRAPH(K,I)+CLDTEMP(K,I)*PAFRAC 203 CONTINUE END IF C C Advance quantities one time step, applying Asselin filter C DO 180 K=2,NLO-1 C IF(TSINT.EQ.'y'.OR.TSINT.EQ.'Y')THEN TS3(K)=TS1(K)+2.*DT*FTS(K) TS3(K)=MAX(TS3(K),270.0) TS1(K)=TS2(K)+AFILT*(TS1(K)+TS3(K)-2.*TS2(K)) TS2(K)=TS3(K) END IF C SM3(K)=SM1(K)+2.*DT*FSOIL(K) SM1(K)=SM2(K)+AFILT*(SM1(K)+SM3(K)-2.*SM2(K)) SM2(K)=SM3(K) C DO 160 I=1,NP T3(K,I)=T1(K,I)+2.*DT*FTNET(K,I) R3(K,I)=R1(K,I)+2.*DT*FRNET(K,I) T1(K,I)=T2(K,I)+AFILT*(T1(K,I)+T3(K,I)-2.*T2(K,I)) R1(K,I)=R2(K,I)+AFILT*(R1(K,I)+R3(K,I)-2.*R2(K,I)) T2(K,I)=T3(K,I) R2(K,I)=R3(K,I) IF(I.LE.NPTOP)THEN ETA3(K,I)=ETA1(K,I)+2.*DT*ETAF(K,I) ETA1(K,I)=ETA2(K,I)+AFILT*(ETA1(K,I)+ETA3(K,I)-2.*ETA2(K,I)) ETA2(K,I)=ETA3(K,I) U3(K,I)=U1(K,I)+2.*DT*UF(K,I) U1(K,I)=U2(K,I)+AFILT*(U1(K,I)+U3(K,I)-2.*U2(K,I)) U2(K,I)=U3(K,I) END IF 160 CONTINUE ETA1(K,1)=ETA1(K,2) C C Find streamfunction C PSI(K,NPTOP)=0.0 ETA2(K,NPTOP)=0.0 FV=0.0 DO 165 I=NPTOP-1,1,-1 FV=FV+ETA2(K,I+1)*100.0*(P(I)-P(I+1)) PSI(K,I)=PSI(K,I+1)+FV*100.0*(PH(I)-PH(I+1)) 165 CONTINUE DO 170 I=NPTOP-1,2,-1 PSI(K,I)=PSI(K,1)*(PH(I)-PH(NPTOP))/(PH(1)-PH(NPTOP))-PSI(K,I) 170 CONTINUE PSI(K,1)=0.0 C 180 CONTINUE C C Return to beginning of time loop C GOTO 100 C C Output processing starts here C 200 CONTINUE NPR=NPR-1 C IF(FWRITE.EQ.'y')THEN FNI=1./FLOAT(NSAVE) DO I=1,NP RV2M(I)=FNI*RV2M(I) CLDFRADM(I)=FNI*CLDFRADM(I) CLDEMIM(I)=FNI*CLDEMIM(I) CLDTAUM(I)=FNI*CLDTAUM(I) END DO END IF C C Subtract horizontal mean temperature from composite temperature C DO 1010 I=1,NP II=MIN(I,NP-1) TEMBAR=0.0 DO 1005 K=2,NLO-1 TEMBAR=TEMBAR+TEMPGRAPH(K,II) 1005 CONTINUE TEMBAR=TEMBAR/FLOAT(NLO-2) DO 1006 K=2,NLO-1 TEMPGRAPH(K,I)=TEMPGRAPH(K,II)-TEMBAR 1006 CONTINUE 1010 CONTINUE C C *** Add boundary conditions to contour plots *** C IF(BCS.EQ.'p')THEN C DO 205 I=1,NPR PGRAPH(1,I)=PGRAPH(NLO-1,I) PGRAPH(NLO,I)=PGRAPH(2,I) CAPEGRAPH(1,I)=CAPEGRAPH(NLO-1,I) CAPEGRAPH(NLO,I)=CAPEGRAPH(2,I) QRGRAPH(1,I)=QRGRAPH(NLO-1,I) QRGRAPH(NLO,I)=QRGRAPH(2,I) OGRAPH(1,I)=OGRAPH(NLO-1,I) OGRAPH(NLO,I)=OGRAPH(2,I) VGRAPH(1,I)=VGRAPH(NLO-1,I) VGRAPH(NLO,I)=VGRAPH(2,I) UTGRAPH(1,I)=UTGRAPH(NLO-1,I) UTGRAPH(NLO,I)=UTGRAPH(2,I) SSTGRAPH(1,I)=SSTGRAPH(NLO-1,I) SSTGRAPH(NLO,I)=SSTGRAPH(2,I) EFRACGRAPH(1,I)=EFRACGRAPH(NLO-1,I) EFRACGRAPH(NLO,I)=EFRACGRAPH(2,I) T100GRAPH(1,I)=T100GRAPH(NLO-1,I) T100GRAPH(NLO,I)=T100GRAPH(2,I) MPIGRAPH(1,I)=MPIGRAPH(NLO-1,I) MPIGRAPH(NLO,I)=MPIGRAPH(2,I) SWGRAPH(1,I)=SWGRAPH(NLO-1,I) SWGRAPH(NLO,I)=SWGRAPH(2,I) OLRGRAPH(1,I)=OLRGRAPH(NLO-1,I) OLRGRAPH(NLO,I)=OLRGRAPH(2,I) HCGRAPH(1,I)=HCGRAPH(NLO-1,I) HCGRAPH(NLO,I)=HCGRAPH(2,I) LCGRAPH(1,I)=LCGRAPH(NLO-1,I) LCGRAPH(NLO,I)=LCGRAPH(2,I) 205 CONTINUE DO 207 J=1,NP MUPGRAPH(1,J)=MUPGRAPH(NLO-1,J) MUPGRAPH(NLO,J)=MUPGRAPH(2,J) MDGRAPH(1,J)=MDGRAPH(NLO-1,J) MDGRAPH(NLO,J)=MDGRAPH(2,J) OLGRAPH(1,J)=OLGRAPH(NLO-1,J) OLGRAPH(NLO,J)=OLGRAPH(2,J) RHGRAPH(1,J)=RHGRAPH(NLO-1,J) RHGRAPH(NLO,J)=RHGRAPH(2,J) ULGRAPH(1,J)=ULGRAPH(NLO-1,J) ULGRAPH(NLO,J)=ULGRAPH(2,J) PSIGRAPH(1,J)=PSIGRAPH(NLO-1,J) PSIGRAPH(NLO,J)=PSIGRAPH(2,J) TEMPGRAPH(1,J)=TEMPGRAPH(NLO-1,J) TEMPGRAPH(NLO,J)=TEMPGRAPH(2,J) TEMPGRAPHNET(1,J)=TEMPGRAPHNET(NLO-1,J) TEMPGRAPHNET(NLO,J)=TEMPGRAPHNET(2,J) AMGRAPH(1,J)=AMGRAPH(NLO-1,J) AMGRAPH(NLO,J)=AMGRAPH(2,J) CLDGRAPH(1,J)=CLDGRAPH(NLO-1,J) CLDGRAPH(NLO,J)=CLDGRAPH(2,J) 207 CONTINUE C ELSE C DO 206 I=1,NPR PGRAPH(1,I)=PGRAPH(2,I) PGRAPH(NLO,I)=PGRAPH(NLO-1,I) CAPEGRAPH(1,I)=CAPEGRAPH(2,I) CAPEGRAPH(NLO,I)=CAPEGRAPH(NLO-1,I) QRGRAPH(1,I)=QRGRAPH(2,I) QRGRAPH(NLO,I)=QRGRAPH(NLO-1,I) OGRAPH(1,I)=OGRAPH(2,I) OGRAPH(NLO,I)=OGRAPH(NLO-1,I) VGRAPH(1,I)=0.0 VGRAPH(NLO,I)=0.0 UTGRAPH(1,I)=0.0 UTGRAPH(NLO,I)=0.0 SSTGRAPH(1,I)=SSTGRAPH(2,I) SSTGRAPH(NLO,I)=SSTGRAPH(NLO-1,I) EFRACGRAPH(1,I)=EFRACGRAPH(2,I) EFRACGRAPH(NLO,I)=EFRACGRAPH(NLO-1,I) T100GRAPH(1,I)=T100GRAPH(2,I) T100GRAPH(NLO,I)=T100GRAPH(NLO-1,I) MPIGRAPH(1,I)=MPIGRAPH(2,I) MPIGRAPH(NLO,I)=MPIGRAPH(NLO-1,I) SWGRAPH(1,I)=SWGRAPH(2,I) SWGRAPH(NLO,I)=SWGRAPH(NLO-1,I) OLRGRAPH(1,I)=OLRGRAPH(2,I) OLRGRAPH(NLO,I)=OLRGRAPH(NLO-1,I) HCGRAPH(1,I)=HCGRAPH(2,I) HCGRAPH(NLO,I)=HCGRAPH(NLO-1,I) LCGRAPH(1,I)=LCGRAPH(2,I) LCGRAPH(NLO,I)=LCGRAPH(NLO-1,I) 206 CONTINUE DO 208 J=1,NP MUPGRAPH(1,J)=MUPGRAPH(2,J) MUPGRAPH(NLO,J)=MUPGRAPH(NLO-1,J) MDGRAPH(1,J)=MDGRAPH(2,J) MDGRAPH(NLO,J)=MDGRAPH(NLO-1,J) OLGRAPH(1,J)=OLGRAPH(2,J) OLGRAPH(NLO,J)=OLGRAPH(NLO-1,J) RHGRAPH(1,J)=RHGRAPH(2,J) RHGRAPH(NLO,J)=RHGRAPH(NLO-1,J) ULGRAPH(1,J)=0.0 ULGRAPH(NLO,J)=0.0 PSIGRAPH(1,J)=0.0 PSIGRAPH(NLO,J)=0.0 TEMPGRAPH(1,J)=TEMPGRAPH(2,J) TEMPGRAPH(NLO,J)=TEMPGRAPH(NLO-1,J) TEMPGRAPHNET(1,J)=TEMPGRAPHNET(2,J) TEMPGRAPHNET(NLO,J)=TEMPGRAPHNET(NLO-1,J) AMGRAPH(NLO,J)=AMGRAPH(NLO-1,J) AMGRAPH(1,J)=AMGRAPH(2,J) CLDGRAPH(1,J)=CLDGRAPH(2,J) CLDGRAPH(NLO,J)=CLDGRAPH(NLO-1,J) 208 CONTINUE C END IF C C *** Write contour plot ASCII files *** C DO 400 I=1,NLO DISX(I)=0.001*DX*FLOAT(I-1) 400 CONTINUE C OPEN(UNIT=12, FILE='output/x.out',STATUS='UNKNOWN') WRITE(12,425)(DISX(I),I=1,NLO) CLOSE(12) C OPEN(UNIT=12, FILE='output/x2.out',STATUS='UNKNOWN') WRITE(12,425)((DISX(I)+0.0005*DX),I=1,NLO-1) CLOSE(12) C OPEN(UNIT=12, FILE='output/t.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,435)GTIME(I) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/p.out',STATUS='UNKNOWN') WRITE(12,437)(P(I),I=1,NP) CLOSE(12) C 425 FORMAT(2X,200(F9.1,' ')) 435 FORMAT(2X,500(F14.5,' ')) 437 FORMAT(2X,100(F9.1,' ')) C OPEN(UNIT=12, FILE='output/precip.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(PGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/omegat.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(OGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/vt.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(VGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/ut.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(UTGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/sst.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(SSTGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/efrac.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(EFRACGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/t100.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(T100GRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/mpi.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(MPIGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/sw.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(SWGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/olr.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(OLRGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/hc.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(HCGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/lc.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(LCGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12,FILE='output/cape.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(CAPEGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12,FILE='output/qr.out',STATUS='UNKNOWN') DO I=1,NPR WRITE(12,445)(QRGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/omegal.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(OLGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/mul.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(MUPGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/mdl.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(MDGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/psi.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(PSIGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/rh.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(RHGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/cld.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(CLDGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/ul.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(ULGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/temp.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(TEMPGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/am.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(AMGRAPH(J,I),J=1,NLO) END DO CLOSE(12) C OPEN(UNIT=12, FILE='output/tempnet.out',STATUS='UNKNOWN') DO I=1,NP WRITE(12,445)(TEMPGRAPHNET(J,I),J=1,NLO) END DO CLOSE(12) C 445 FORMAT(2X,200(F10.4,' ')) 450 CONTINUE C OPEN(UNIT=12, FILE='output/flux.out',STATUS='UNKNOWN') DO K=1,NLO-1 WRITE(12,*)(DISX(K)+0.0005*DX),AFLUXGRAPH(K),OFLUXGRAPH(K), 1 NETFLUXGRAPH(K) END DO CLOSE(12) C C Output to file sounding.out C OPEN(UNIT=10, FILE='output/sounding.out', STATUS='unknown') C DO 350 K=2,NLO-1 TS2C=TS2(K)-273.15 WRITE(10,210) NP,QGRAPH(K,NPR),TS2C 210 FORMAT(2X, 'N levels = ',T15,I3,T26,'Q=',F5.2,' m/s', 1 T48,'SST=',T55,F5.2,' C',/) C WRITE(10,220) 220 FORMAT(2X,'Pressure',T14,'Temp.',T25,'Spec. humid.',T40, 1 'O3 mr',T49, 'Psi',T57,'Rcool',T67,'U') WRITE(10,230) 230 FORMAT(4X,'(mb)',T15,'(C)',T28,'(g/kg)',T40,'10**-6',T47, 1 'E4 kg/m/s',T57,'(K/dy)',T66,'m/s') WRITE(10,240) 240 FORMAT(2X,'-------',T14,'-----',T25,'------------',T40, 1 '-----',T48, '-----',T57,'------',T67,'-') c DO 260 I=1,NP OZ=1.0E6*O3(I) TC=T2(K,I)-273.15 RM=1000.0*R2(K,I) AOMEG=PSI(K,I)*1.0E-4 ARADC=RCOOL(K,I)*3600.*24. WRITE(10,250)P(I),TC,RM,OZ,AOMEG,ARADC,U2(K,I) 250 FORMAT(3X,F6.1,T12,F8.3,T25,F10.6,T39,F6.3,T47,F6.2, 1 T56,F7.3,T64,F5.1) 260 CONTINUE 350 CONTINUE CLOSE(10) IF(FWRITE.EQ.'y')THEN OPEN(10,FILE='output/variables',form='unformatted', 1 status='unknown') WRITE(10) RV2M,CLDFRADM,CLDEMIM,CLDTAUM CLOSE(10) END IF STOP END C SUBROUTINE PCMIN(SST,PSL,P,T,R,NA,N,PMIN,VMAX,IFL) C C *** This subroutine calculates the mimimum central pressure *** C *** and maximum 10 m 1 minute wind speed *** C *** achievable in tropical cyclones, given a sounding *** C *** and a sea surface temperature. *** C C INPUT: SST: Sea surface temperature in C C C PSL: Sea level pressure (mb) C C P,T,R: One-dimensional arrays of dimension NA C containing pressure (mb), temperature (K), C and mixing ratio (kg/kg). The arrays MUST be C arranged so that the lowest index corresponds C to the lowest model level, with increasing index C corresponding to decreasing pressure. The temperature C sounding should extend to at least the tropopause and C preferably to the lower stratosphere, however the C mixing ratios are not important above the boundary C layer. Missing mixing ratios can be replaced by zeros. C C NA: The dimension of P,T and R C C N: The actual number of points in the sounding C (N is less than or equal to NA) C C OUTPUT: PMIN is the minimum central pressure, in mb C C VMAX is the maximum surface wind speed, in m/s C (reduced to reflect surface drag) C C IFL is a flag: A value of 1 means OK; a value of 0 C indicates no convergence (hypercane); a value of 2 C means that the CAPE routine failed. C C----------------------------------------------------------------------------- REAL T(NA), P(NA), R(NA) C C *** Adjustable constant: Ratio of C_k to C_D *** C CKCD=0.9 C C *** Adjustable constant for buoyancy of displaced parcels: *** C *** 0=Reversible ascent; 1=Pseudo-adiabatic ascent *** C SIG=0.5 C C *** Adjustable switch: if IDISS = 0, no dissipative heating is *** C *** allowed; otherwise, it is *** C IDISS=1 C C *** Normalize certain quantities *** C SSTK=SST+273.15 ES0=6.112*EXP(17.67*SST/(243.5+SST)) C C *** Default values *** C VMAX=0.0 PMIN=PSL IFL=1 C NP=0 PM=950.0 C C *** Find environmental CAPE *** C TP=T(1) RP=R(1) PP=P(1) CALL CAPE(TP,RP,PP,T,R,P,NA,N,SIG,CAPEA,TOA,IFLAG) IF(IFLAG.NE.1)IFL=2 C C *** Begin iteration to find mimimum pressure *** C 100 CONTINUE C C *** Find CAPE at radius of maximum winds *** C TP=T(1) PP=PM RP=0.622*R(1)*PSL/(PM*(0.622+R(1))-R(1)*PSL) CALL CAPE(TP,RP,PP,T,R,P,NA,N,SIG,CAPEM,TOM,IFLAG) IF(IFLAG.NE.1)IFL=2 RAT=SSTK/MAX(TOM,1.0) IF(IDISS.EQ.0)RAT=1.0 C C *** Find saturation CAPE at radius of maximum winds *** C TP=SSTK PP=PM RP=0.622*ES0/(PM-ES0) CALL CAPE(TP,RP,PP,T,R,P,NA,N,SIG,CAPEMS,TOMS,IFLAG) IF(IFLAG.NE.1)IFL=2 C C *** Initial estimate of minimum pressure *** C RS0=RP TV1=T(1)*(1.+R(1)/0.622)/(1.+R(1)) TVAV=0.5*(TV1+SSTK*(1.+RS0/0.622)/(1.+RS0)) CAT=CAPEM-CAPEA+0.5*CKCD*RAT*(CAPEMS-CAPEM) PNEW=PSL*EXP(-CAT/(287.04*TVAV)) C C *** Test for convergence *** C IF(ABS(PNEW-PM).GT.0.2)THEN PM=PNEW NP=NP+1 IF(NP.GT.1000.OR.PM.LT.400.0)THEN PMIN=400.0 IFL=0 GOTO 900 END IF GOTO 100 ELSE CAT=CAPEM-CAPEA+CKCD*RAT*(CAPEMS-CAPEM) PMIN=PSL*EXP(-CAT/(287.04*TVAV)) END IF 900 CONTINUE FAC=MAX(0.0,(CAPEMS-CAPEM)) VMAX=0.8*SQRT(CKCD*RAT*FAC) C C *** Renormalize sounding arrays *** C DO 910 I=1,N R(I)=R(I)*1000.0 T(I)=T(I)-273.15 910 CONTINUE C RETURN END C SUBROUTINE CAPE(TP,RP,PP,T,R,P,ND,N,SIG,CAPED,TO,IFLAG) C C This subroutine calculates the CAPE of a parcel with pressure PP (mb), C temperature TP (K) and mixing ratio RP (gm/gm) given a sounding C of temperature (T in K) and mixing ratio (R in gm/gm) as a function C of pressure (P in mb). ND is the dimension of the arrays T,R and P, C while N is the actual number of points in the sounding. CAPED is C the calculated value of CAPE and TO is the temperature at the C level of neutral buoyancy. IFLAG is a flag C integer. If IFLAG = 1, routine is successful; if it is 0, routine did C not run owing to improper sounding (e.g.no water vapor at parcel level). C IFLAG=2 indicates that routine did not converge. C REAL T(ND),R(ND),P(ND),TVRDIF(100) REAL NA C C *** Default values *** C CAPED=0.0 TO=T(1) IFLAG=1 C C *** Check that sounding is suitable *** C IF(RP.LT.1.0E-6.OR.TP.LT.200.0)THEN IFLAG=0 RETURN END IF C C *** Assign values of thermodynamic constants *** C CPD=1005.7 CPV=1870.0 CL=2500.0 C CPVMCL=2320.0 CPVMCL=CL-CPV RV=461.5 RD=287.04 EPS=RD/RV ALV0=2.501E6 C C *** Define various parcel quantities, including reversible *** C *** entropy, S. *** C TPC=TP-273.15 ESP=6.112*EXP(17.67*TPC/(243.5+TPC)) EVP=RP*PP/(EPS+RP) RH=EVP/ESP ALV=ALV0-CPVMCL*TPC S=(CPD+RP*CL)*LOG(TP)-RD*LOG(PP-EVP)+ 1 ALV*RP/TP-RP*RV*LOG(RH) C C *** Find lifted condensation pressure, PLCL *** C CHI=TP/(1669.0-122.0*RH-TP) PLCL=PP*(RH**CHI) C C *** Begin updraft loop *** C NCMAX=0 DO J=1,N TVRDIF(J)=0.0 END DO DO 200 J=2,N C C *** Don't bother lifting parcel above 60 mb *** C IF(P(J).LT.59.0)GOTO 200 C C *** Parcel quantities below lifted condensation level *** C IF(P(J).GE.PLCL)THEN TG=TP*(P(J)/PP)**(RD/CPD) RG=RP C C *** Calculate buoyancy *** C TLVR=TG*(1.+RG/EPS)/(1.+RG) TVRDIF(J)=TLVR-T(J)*(1.+R(J)/EPS)/(1.+R(J)) ELSE C C *** Parcel quantities above lifted condensation level *** C TG=T(J) TJC=T(J)-273.15 ES=6.112*EXP(17.67*TJC/(243.5+TJC)) RG=EPS*ES/(P(J)-ES) C C *** Iteratively calculate lifted parcel temperature and mixing *** C *** ratio for reversible ascent *** C NC=0 120 CONTINUE NC=NC+1 C C *** Calculate estimates of the rates of change of the entropy *** C *** with temperature at constant pressure *** C ALV=ALV0-CPVMCL*(TG-273.15) SL=(CPD+RP*CL+ALV*ALV*RG/(RV*TG*TG))/TG EM=RG*P(J)/(EPS+RG) SG=(CPD+RP*CL)*LOG(TG)-RD*LOG(P(J)-EM)+ 1 ALV*RG/TG IF(NC.LT.3)THEN AP=0.3 ELSE AP=1.0 END IF TGNEW=TG+AP*(S-SG)/SL C C *** Test for convergence *** C IF(ABS(TGNEW-TG).GT.0.01)THEN TG=TGNEW TC=TG-273.15 ENEW=6.112*EXP(17.67*TC/(243.5+TC)) C C *** Bail out if things get out of hand *** C IF(NC.GT.500.OR.ENEW.GT.(P(J)-1.0))THEN IFLAG=2 RETURN END IF RG=EPS*ENEW/(P(J)-ENEW) GOTO 120 END IF NCMAX=MAX(NC,NCMAX) C C *** Calculate buoyancy *** C RMEAN=SIG*RG+(1.-SIG)*RP TLVR=TG*(1.+RG/EPS)/(1.+RMEAN) TVRDIF(J)=TLVR-T(J)*(1.+R(J)/EPS)/(1.+R(J)) END IF 200 CONTINUE C C *** Begin loop to find NA, PA, and CAPE from reversible ascent *** C NA=0.0 PA=0.0 C C *** Find maximum level of positive buoyancy, INB *** C INB=1 DO 550 J=N,1,-1 IF(TVRDIF(J).GT.0.0)INB=MAX(INB,J) 550 CONTINUE C C *** Find positive and negative areas and CAPE *** C IF(INB.GT.1)THEN DO 600 J=2,INB TVM=0.5*(TVRDIF(J)+TVRDIF(J-1)) PMA=0.5*(P(J)+P(J-1)) IF(TVM.LE.0.0)THEN NA=NA-RD*TVM*(P(J-1)-P(J))/PMA ELSE PA=PA+RD*TVM*(P(J-1)-P(J))/PMA END IF 600 CONTINUE C C *** Find residual positive area above INB and TO *** C PAT=0.0 TO=T(INB) IF(INB.LT.N)THEN PINB=(P(INB+1)*TVRDIF(INB)-P(INB)*TVRDIF(INB+1))/ 1 (TVRDIF(INB)-TVRDIF(INB+1)) PAT=RD*TVRDIF(INB)*(P(INB)-PINB)/(P(INB)+PINB) TO=(T(INB)*(PINB-P(INB+1))+T(INB+1)*(P(INB)-PINB))/ 1 (P(INB)-P(INB+1)) END IF C C *** Find CAPE *** C CAPED=PA+PAT-NA CAPED=MAX(CAPED,0.0) END IF C RETURN END C *************************************************************************** ***** SUBROUTINE CONVECT ***** ***** VERSION 4.3b ***** ***** 20 August, 2000 ***** ***** Kerry Emanuel ***** *************************************************************************** C SUBROUTINE CONVECT * (T, Q, QS, U, V, TRA, P, PH, * ND, NL, NTRA, DELT, IFLAG, FT, FQ, FU, * FV, FTRA, PRECIP, WD, TPRIME, QPRIME, QCONDC,CBMF,FS,FL) C C----------------------------------------------------------------------------- C *** On input: *** C C T: Array of absolute temperature (K) of dimension ND, with first C index corresponding to lowest model level. Note that this array C will be altered by the subroutine if dry convective adjustment C occurs and if IPBL is not equal to 0. C C Q: Array of specific humidity (gm/gm) of dimension ND, with first C index corresponding to lowest model level. Must be defined C at same grid levels as T. Note that this array will be altered C if dry convective adjustment occurs and if IPBL is not equal to 0. C C QS: Array of saturation specific humidity of dimension ND, with first C index corresponding to lowest model level. Must be defined C at same grid levels as T. Note that this array will be altered C if dry convective adjustment occurs and if IPBL is not equal to 0. C C U: Array of zonal wind velocity (m/s) of dimension ND, witth first C index corresponding with the lowest model level. Defined at C same levels as T. Note that this array will be altered if C dry convective adjustment occurs and if IPBL is not equal to 0. C C V: Same as U but for meridional velocity. C C TRA: Array of passive tracer mixing ratio, of dimensions (ND,NTRA), C where NTRA is the number of different tracers. If no C convective tracer transport is needed, define a dummy C input array of dimension (ND,1). Tracers are defined at C same vertical levels as T. Note that this array will be altered C if dry convective adjustment occurs and if IPBL is not equal to 0. C C P: Array of pressure (mb) of dimension ND, with first C index corresponding to lowest model level. Must be defined C at same grid levels as T. C C PH: Array of pressure (mb) of dimension ND+1, with first index C corresponding to lowest level. These pressures are defined at C levels intermediate between those of P, T, Q and QS. The first C value of PH should be greater than (i.e. at a lower level than) C the first value of the array P. C C ND: The dimension of the arrays T,Q,QS,P,PH,FT and FQ C C NL: The maximum number of levels to which convection can C penetrate, plus 1. C NL MUST be less than or equal to ND-1. C C NTRA:The number of different tracers. If no tracer transport C is needed, set this equal to 1. (On most compilers, setting C NTRA to 0 will bypass tracer calculation, saving some CPU.) C C DELT: The model time step (sec) between calls to CONVECT C C -- sb: interface with the cloud parameterization: C C QCONDC: mixing ratio of condensed water within clouds (kg/kg) C For use in the Bony-Emanuel cloud parameterization C sb -- C C---------------------------------------------------------------------------- C *** On Output: *** C C IFLAG: An output integer whose value denotes the following: C C VALUE INTERPRETATION C ----- -------------- C 0 No moist convection; atmosphere is not C unstable, or surface temperature is less C than 250 K or surface specific humidity C is non-positive. C C 1 Moist convection occurs. C C 2 No moist convection: lifted condensation C level is above the 200 mb level. C C 3 No moist convection: cloud base is higher C then the level NL-1. C C 4 Moist convection occurs, but a CFL condition C on the subsidence warming is violated. This C does not cause the scheme to terminate. C C FT: Array of temperature tendency (K/s) of dimension ND, defined at same C grid levels as T, Q, QS and P. C C FQ: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, C defined at same grid levels as T, Q, QS and P. C C FU: Array of forcing of zonal velocity (m/s^2) of dimension ND, C defined at same grid levels as T. C C FV: Same as FU, but for forcing of meridional velocity. C C FTRA: Array of forcing of tracer content, in tracer mixing ratio per C second, defined at same levels as T. Dimensioned (ND,NTRA). C C PRECIP: Scalar convective precipitation rate (mm/day). C C WD: A convective downdraft velocity scale. For use in surface C flux parameterizations. See convect.ps file for details. C C TPRIME: A convective downdraft temperature perturbation scale (K). C For use in surface flux parameterizations. See convect.ps C file for details. C C QPRIME: A convective downdraft specific humidity C perturbation scale (gm/gm). C For use in surface flux parameterizations. See convect.ps C file for details. C C CBMF: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST C BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT C ITS NEXT CALL. That is, the value of CBMF must be "remembered" C by the calling program between calls to CONVECT. C C------------------------------------------------------------------------------ C C *** THE PARAMETER NA SHOULD IN GENERAL BE GREATER THAN *** C *** OR EQUAL TO ND + 1 *** C PARAMETER (NA=50) C INTEGER NENT(NA) REAL T(ND),Q(ND),QS(ND),U(ND),V(ND),TRA(ND,NTRA),P(ND),PH(ND) REAL FT(ND),FQ(ND),FU(ND),FV(ND),FTRA(ND,NTRA) REAL TRAENT(NA,NA,NTRA),TRATM(NA) REAL UP(NA),VP(NA),TRAP(NA,NTRA) REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA) REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA) REAL QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA) REAL SIGP(NA),TP(NA),TOLD(NA),CPN(NA),LAMBDA REAL LV(NA),LVCP(NA),LV0,H(NA),HP(NA),GZ(NA),HM(NA) C -- ke 8/04 REAL UC(NA), VC(NA), UH(NA), VH(NA), FLUXU(NA), FLUXV(NA) C -- sb: REAL QCONDC(ND) REAL QCOND(NA),NQCOND(NA),WA(NA),MA(NA),SIGA(NA),AX(NA) C REAL MUP(NA),MDOWN(NA),ENT(NA),DET(NA),FQDET(NA),FQSUB(NA) COMMON / CVT / TVP,MP,QP,SIJ,MUP,MDOWN,ENT,DET,FQDET,FQSUB, 1 WATER, INB, CAPEM C C ----------------------------------------------------------------------- C C *** Specify Switches *** C C *** IPBL: Set to zero to bypass dry adiabatic adjustment *** C *** Any other value results in dry adiabatic adjustment *** C *** (Zero value recommended for use in models with *** C *** boundary layer schemes) *** C C *** MINORIG: Lowest level from which convection may originate *** C *** (Should be first model level at which T is defined *** C *** for models using bulk PBL schemes; otherwise, it should *** C *** be the first model level at which T is defined above *** C *** the surface layer) *** C IPBL=1 MINORIG=1 C C------------------------------------------------------------------------------ C C *** SPECIFY PARAMETERS *** C C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** C *** BETWEEN 0 C AND TLCRIT) *** C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** C *** FORMULATION *** C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** C *** OF CLOUD *** C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** C *** OF RAIN *** C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** C *** OF SNOW *** C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** C *** TRANSPORT *** C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** C *** APPROACH TO QUASI-EQUILIBRIUM *** C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** C *** (DAMP MUST BE LESS THAN 1) *** C ELCRIT=.0011 TLCRIT=-55.0 ENTP=1.5 SIGD=0.05 SIGS=0.12 SIGMIN=0.0 SIGMAX=0.9 OMTRAIN=50.0 OMTSNOW=5.5 COEFFR=0.9 COEFFS=0.6 LAMBDA=0.001/250.0 BETA=10.0 DTMAX=0.9 ALPHA=0.02 DAMP=0.1 DELTA=0.01 ! sb (for cloud parameterization) C c DTMAX=0.1*DTMAX1*(T(1)-273.15) c DTMAX=MIN(DTMAX,DTMAX1) c DTMAX=MAX(DTMAX,0.0) C C *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS, *** C *** GRAVITY, AND LIQUID WATER DENSITY. *** C *** THESE SHOULD BE CONSISTENT WITH *** C *** THOSE USED IN CALLING PROGRAM *** C *** NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT *** C CPD=1005.7 CPV=1870.0 CL=2500.0 RV=461.5 RD=287.04 LV0=2.501E6 G=9.8 ROWL=1000.0 C CPVMCL=CL-CPV EPS=RD/RV EPSI=1./EPS GINV=1.0/G DELTI=1.0/DELT C C *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS *** C DO 5 I=1,ND FT(I)=0.0 FQ(I)=0.0 FU(I)=0.0 FV(I)=0.0 C -- sb: QCONDC(I)=0.0 QCOND(I)=0.0 NQCOND(I)=0.0 DO 4 J=1,NTRA FTRA(I,J)=0.0 4 CONTINUE MDOWN(I)=0.0 MUP(I)=0.0 ENT(I)=0.0 DET(I)=0.0 FQDET(I)=0.0 FQSUB(I)=0.0 WATER(I)=0.0 QP(I)=Q(I) MP(I)=0.0 TVP(I)=T(I)*(1.+Q(I)*EPSI-Q(I)) 5 CONTINUE DO 7 I=1,NL+1 RDCP=(RD*(1.-Q(I))+Q(I)*RV)/ 1 (CPD*(1.-Q(I))+Q(I)*CPV) TH(I)=T(I)*(1000.0/P(I))**RDCP 7 CONTINUE PRECIP=0.0 WD=0.0 TPRIME=0.0 QPRIME=0.0 IFLAG=0 INB=ND C C -- added by ke 8/04 C C *** INTERPOLATE TO FIND VELOCITIES AT HALF LEVELS *** C UH(ND)=U(ND) VH(ND)=V(ND) UC(ND)=UH(ND) VC(ND)=VH(ND) UP(ND)=UH(ND) VP(ND)=VH(ND) DO I=1,ND-1 UH(I)=0.5*(U(I)+U(I+1)) VH(I)=0.5*(V(I)+V(I+1)) UC(I)=UH(I) VC(I)=VH(I) UP(I)=UH(I) VP(I)=VH(I) END DO C C -- end of addition C IF(IPBL.NE.0)THEN C C *** PERFORM DRY ADIABATIC ADJUSTMENT *** C JC=0 DO 30 I=NL-1,1,-1 JN=0 SUM=TH(I)*(1.+Q(I)*EPSI-Q(I)) DO 10 J=I+1,NL SUM=SUM+TH(J)*(1.+Q(J)*EPSI-Q(J)) THBAR=SUM/FLOAT(J+1-I) IF((TH(J)*(1.+Q(J)*EPSI-Q(J))).LT.THBAR)JN=J IF(I.EQ.1.AND.P(J).GT.948.)JN=MAX(JN,J) 10 CONTINUE c IF(I.EQ.1)JN=MAX(JN,3) IF(JN.EQ.0)GOTO 30 12 CONTINUE AHM=0.0 RM=0.0 UM=0.0 VM=0.0 DO K=1,NTRA TRATM(K)=0.0 END DO DO 15 J=I,JN AHM=AHM+(CPD*(1.-Q(J))+Q(J)*CPV)*T(J)*(PH(J)-PH(J+1)) RM=RM+Q(J)*(PH(J)-PH(J+1)) UM=UM+U(J)*(PH(J)-PH(J+1)) VM=VM+V(J)*(PH(J)-PH(J+1)) DO K=1,NTRA TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1)) END DO 15 CONTINUE DPHINV=1./(PH(I)-PH(JN+1)) RM=RM*DPHINV UM=UM*DPHINV VM=VM*DPHINV DO K=1,NTRA TRATM(K)=TRATM(K)*DPHINV END DO A2=0.0 DO 20 J=I,JN Q(J)=RM U(J)=UM V(J)=VM DO K=1,NTRA TRA(J,K)=TRATM(K) END DO RDCP=(RD*(1.-Q(J))+Q(J)*RV)/ 1 (CPD*(1.-Q(J))+Q(J)*CPV) X=(0.001*P(J))**RDCP TOLD(J)=T(J) T(J)=X A2=A2+(CPD*(1.-Q(J))+Q(J)*CPV)*X*(PH(J)-PH(J+1)) 20 CONTINUE DO 25 J=I,JN TH(J)=AHM/A2 T(J)=T(J)*TH(J) TC=TOLD(J)-273.15 ALV=LV0-CPVMCL*TC QS(J)=QS(J)+QS(J)*(1.+QS(J)*0.608)*ALV*(T(J)- 1 TOLD(J))/(RV*TOLD(J)*TOLD(J)) 25 CONTINUE IF((TH(JN+1)*(1.+Q(JN+1)*EPSI-Q(JN+1))).LT. 1 (TH(JN)*(1.+Q(JN)*EPSI-Q(JN))))THEN JN=JN+1 GOTO 12 END IF IF(I.EQ.1)JC=JN 30 CONTINUE C C *** Remove any supersaturation that results from adjustment *** C IF(JC.GT.1)THEN DO 38 J=1,JC IF(QS(J).LT.Q(J))THEN ALV=LV0-CPVMCL*(T(J)-273.15) TNEW=T(J)+ALV*(Q(J)-QS(J))/(CPD*(1.-Q(J))+ 1 CL*Q(J)+QS(J)*(CPV-CL+ALV*ALV/(RV*T(J)*T(J)))) ALVNEW=LV0-CPVMCL*(TNEW-273.15) QNEW=(ALV*Q(J)-(TNEW-T(J))*(CPD*(1.-Q(J))+CL*Q(J)))/ALVNEW PRECIP=PRECIP+24.*3600.*1.0E5*(PH(J)-PH(J+1))* 1 (Q(J)-QNEW)/(G*DELT*ROWL) T(J)=TNEW Q(J)=QNEW QS(J)=QNEW END IF 38 CONTINUE END IF C END IF C C *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY C GZ(1)=0.0 CPN(1)=CPD*(1.-Q(1))+Q(1)*CPV H(1)=T(1)*CPN(1) LV(1)=LV0-CPVMCL*(T(1)-273.15) HM(1)=LV(1)*Q(1) TV(1)=T(1)*(1.+Q(1)*EPSI-Q(1)) AHMIN=1.0E12 IHMIN=NL DO 40 I=2,NL+1 TVX=T(I)*(1.+Q(I)*EPSI-Q(I)) TVY=T(I-1)*(1.+Q(I-1)*EPSI-Q(I-1)) GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I) CPN(I)=CPD*(1.-Q(I))+CPV*Q(I) H(I)=T(I)*CPN(I)+GZ(I) LV(I)=LV0-CPVMCL*(T(I)-273.15) HM(I)=(CPD*(1.-Q(I))+CL*Q(I))*(T(I)-T(1))+ 1 LV(I)*Q(I)+GZ(I) TV(I)=T(I)*(1.+Q(I)*EPSI-Q(I)) C C *** Find level of minimum moist static energy *** C IF(I.GE.MINORIG.AND.HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN AHMIN=HM(I) IHMIN=I END IF 40 CONTINUE IHMIN=MIN(IHMIN, NL-1) C C *** Find that model level below the level of minimum moist *** C *** static energy that has the maximum value of moist static energy *** C AHMAX=0.0 DO 42 I=MINORIG,IHMIN IF(HM(I).GT.AHMAX)THEN NK=I AHMAX=HM(I) END IF 42 CONTINUE C C *** CHECK WHETHER PARCEL LEVEL TEMPERATURE AND SPECIFIC HUMIDITY *** C *** ARE REASONABLE *** C *** Skip convection if HM increases monotonically upward *** C IF(T(NK).LT.250.0.OR.Q(NK).LE.0.0.OR.IHMIN.EQ.(NL-1))THEN IFLAG=0 CBMF=0.0 RETURN END IF C C *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT PARCEL ORIGIN LEVEL *** C *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) *** C RH=Q(NK)/QS(NK) CHI=T(NK)/(1669.0-122.0*RH-T(NK)) PLCL=P(NK)*(RH**CHI) IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN IFLAG=2 CBMF=0.0 RETURN END IF PBLH=(RD*T(NK)/G)*LOG(P(1)/PLCL) ROWS=100.*P(1)/(RD*T(1)) W3=PBLH*G*(FS/(CPD*T(1))+0.608*FL/2.5E6)/ROWS W3=MAX(W3,0.0) WSTAR=W3**(1./3.) DTMAX=1.737*WSTAR dtmax=max(dtmax,0.9) C C *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) *** C ICB=NL-1 DO 50 I=NK+1,NL IF(P(I).LT.PLCL)THEN ICB=MIN(ICB,I) END IF 50 CONTINUE IF(ICB.GE.(NL-1))THEN IFLAG=3 CBMF=0.0 RETURN END IF C C *** FIND TEMPERATURE UP THROUGH ICB AND TEST FOR INSTABILITY *** C C *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL *** C *** TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC *** C *** LIQUID WATER CONTENT *** C CALL TLIFT(P,T,Q,QS,GZ,ICB,NK,TVP,TP,CLW,ND,NL,1) DO 54 I=NK,ICB TVP(I)=TVP(I)-TP(I)*Q(NK) 54 CONTINUE C C *** If there was no convection at last time step and parcel *** C *** is stable at ICB then skip rest of calculation *** C IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN IFLAG=0 RETURN END IF C C *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY *** C IF(IFLAG.NE.4)IFLAG=1 C C *** FIND THE REST OF THE LIFTED PARCEL TEMPERATURES *** C CALL TLIFT(P,T,Q,QS,GZ,ICB,NK,TVP,TP,CLW,ND,NL,2) C C *** SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF *** C *** PRECIPITATION FALLING OUTSIDE OF CLOUD *** C *** THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) *** C DO 57 I=1,NK EP(I)=0.0 SIGP(I)=SIGS 57 CONTINUE DO 60 I=NK+1,NL TCA=TP(I)-273.15 IF(TCA.GE.0.0)THEN ELACRIT=ELCRIT ELSE ELACRIT=ELCRIT*(1.0-TCA/TLCRIT) END IF ELACRIT=MAX(ELACRIT,0.0) EPMAX=0.999 EP(I)=EPMAX*(1.0-ELACRIT/MAX(CLW(I),1.0E-8)) EP(I)=MAX(EP(I),0.0) EP(I)=MIN(EP(I),EPMAX) SIGP(I)=SIGS 60 CONTINUE C C *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL *** C *** VIRTUAL TEMPERATURE *** C DO 64 I=ICB+1,NL c TVP(I)=TVP(I)*(1.-Q(NK)+EP(I)*CLW(I)) TVP(I)=TVP(I)-Q(NK)*TP(I) 64 CONTINUE TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD C C *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS *** C DO 70 I=1,NL+1 HP(I)=H(I) NENT(I)=0 WATER(I)=0.0 EVAP(I)=0.0 WT(I)=OMTSNOW MP(I)=0.0 M(I)=0.0 LVCP(I)=LV(I)/CPN(I) C -- ke 8/04 FLUXU(I)=0.0 FLUXV(I)=0.0 C -- DO 70 J=1,NL+1 QENT(I,J)=Q(J) ELIJ(I,J)=0.0 MENT(I,J)=0.0 SIJ(I,J)=0.0 DO 70 K=1,NTRA TRAENT(I,J,K)=TRA(J,K) 70 CONTINUE QP(1)=Q(1) DO 71 I=1,NTRA TRAP(1,I)=TRA(1,I) 71 CONTINUE DO 72 I=2,NL+1 QP(I)=Q(I-1) DO 72 J=1,NTRA TRAP(I,J)=TRA(I-1,J) 72 CONTINUE C C *** FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S *** C *** HIGHEST LEVEL OF NEUTRAL BUOYANCY *** C *** AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) *** C CAPE=0.0 CAPEM=0.0 INB=ICB+1 INB1=INB BYP=0.0 DO 82 I=ICB+1,NL-1 BY=(TVP(I)-TV(I))*(PH(I)-PH(I+1))/P(I) CAPE=CAPE+BY IF(BY.GE.0.0)INB1=I+1 IF(CAPE.GT.0.0)THEN INB=I+1 CAPEM=CAPE BYP=(TVP(I+1)-TV(I+1))*(PH(I+1)-PH(I+2))/P(I+1) END IF 82 CONTINUE c INB=MAX(INB,INB1) INB=(INB+INB1)/2 CAPE=CAPEM+BYP DEFRAC=CAPEM-CAPE DEFRAC=MAX(DEFRAC,0.001) FRAC=-CAPE/DEFRAC FRAC=MIN(FRAC,1.0) FRAC=MAX(FRAC,0.0) JMAX=INB C C *** CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL *** C DO 95 I=ICB,INB HP(I)=H(NK)+(LV(I)+(CPD-CPV)*T(I))*EP(I)*CLW(I) 95 CONTINUE C C *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), *** c *** AT EACH MODEL LEVEL *** C DBOSUM=0.0 C C *** INTERPOLATE DIFFERENCE BETWEEN LIFTED PARCEL AND *** C *** ENVIRONMENTAL TEMPERATURES TO LIFTED CONDENSATION LEVEL *** C TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(P(ICB-1)-PLCL)/ 1 (CPN(ICB-1)*P(ICB-1)) TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-P(ICB))/ 1 (P(ICB)-P(ICB+1)) DTPBL=0.0 DO 96 I=NK,ICB-1 DTPBL=DTPBL+(TVP(I)-TV(I))*(PH(I)-PH(I+1)) 96 CONTINUE DTPBL=DTPBL/(PH(NK)-PH(ICB)) DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL DTMA=DTMIN C C *** ADJUST CLOUD BASE MASS FLUX *** C CBMFOLD=CBMF DELT0=300.0 DAMPS=DAMP*DELT/DELT0 CBMF=(1.-DAMPS)*CBMF+0.1*ALPHA*DTMA c CBMF=0.2*ALPHA*DTMA/DAMPS CBMF=MAX(CBMF,0.0) C C *** If cloud base mass flux is zero, skip rest of calculation *** C IF(CBMF.EQ.0.0.AND.CBMFOLD.EQ.0.0)THEN RETURN END IF C C *** CALCULATE RATES OF MIXING, M(I) *** C M(ICB)=0.0 DO 103 I=ICB+1,INB K=MIN(I,INB1) c DBO=ABS(TV(K+1)-TVP(K+1)-TV(K-1)+TVP(K-1))+ c 1 ENTP*0.04*(PH(K)-PH(K+1)) c c -- modif proposed at NRL (Monterey): DBO=ABS(TV(K)-TVP(K))+ 1 ENTP*0.02*(PH(K)-PH(K+1)) c DBOSUM=DBOSUM+DBO M(I)=CBMF*DBO 103 CONTINUE DO 110 I=ICB+1,INB M(I)=M(I)/DBOSUM 110 CONTINUE C C *** CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING *** C *** RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING *** C *** FRACTION (SIJ) *** C DO 170 I=ICB+1,INB QTI=Q(NK)-EP(I)*CLW(I) DO 160 J=ICB,JMAX BF2=1.+LV(J)*LV(J)*QS(J)/(RV*T(J)*T(J)*CPD) ANUM=H(J)-HP(I)+(CPV-CPD)*T(J)*(QTI-Q(J)) c ANUM=H(J)-HP(I)+(CPV-CPD)*T(J)*(QTI-Q(J))-CPN(J)*Q(NK)*TP(J) DENOM=H(I)-HP(I)+(CPD-CPV)*(Q(I)-QTI)*T(J) DEI=DENOM IF(ABS(DEI).LT.0.01)DEI=0.01 SIJ(I,J)=ANUM/DEI SIJ(I,I)=1.0 ALTEM=SIJ(I,J)*Q(I)+(1.-SIJ(I,J))*QTI-QS(J) ALTEM=ALTEM/BF2 CWAT=CLW(J)*(1.-EP(J)) STEMP=SIJ(I,J) IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR. 1 ALTEM.GT.CWAT).AND.J.GT.I)THEN ANUM=ANUM-LV(J)*(QTI-QS(J)-CWAT*BF2) DENOM=DENOM+LV(J)*(Q(I)-QTI) IF(ABS(DENOM).LT.0.01)DENOM=0.01 SIJ(I,J)=ANUM/DENOM ALTEM=SIJ(I,J)*Q(I)+(1.-SIJ(I,J))*QTI-QS(J) ALTEM=ALTEM-(BF2-1.)*CWAT END IF IF(SIJ(I,J).GT.SIGMIN.AND.SIJ(I,J).LT.SIGMAX)THEN QENT(I,J)=SIJ(I,J)*Q(I)+(1.-SIJ(I,J))*QTI DO K=1,NTRA TRAENT(I,J,K)=SIJ(I,J)*TRA(I,K)+(1.-SIJ(I,J))* 1 TRA(NK,K) END DO ELIJ(I,J)=ALTEM ELIJ(I,J)=MAX(0.0,ELIJ(I,J)) MENT(I,J)=M(I)/(1.-SIJ(I,J)) NENT(I)=NENT(I)+1 END IF SIJ(I,J)=MAX(0.0,SIJ(I,J)) SIJ(I,J)=MIN(1.0,SIJ(I,J)) 160 CONTINUE C C *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS *** C *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES *** C IF(NENT(I).EQ.0)THEN MENT(I,I)=M(I) QENT(I,I)=Q(NK)-EP(I)*CLW(I) DO J=1,NTRA TRAENT(I,I,J)=TRA(NK,J) END DO ELIJ(I,I)=CLW(I) SIJ(I,I)=1.0 END IF 170 CONTINUE SIJ(INB,INB)=1.0 C C *** NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL *** C *** PROBABILITIES OF MIXING *** C DO 200 I=ICB+1,INB IF(NENT(I).NE.0)THEN QP1=Q(NK)-EP(I)*CLW(I) ANUM=H(I)-HP(I)-LV(I)*(QP1-QS(I)) DENOM=H(I)-HP(I)+LV(I)*(Q(I)-QP1) IF(ABS(DENOM).LT.0.01)DENOM=0.01 SCRIT=ANUM/DENOM ALT=QP1-QS(I)+SCRIT*(Q(I)-QP1) IF(ALT.LT.0.0)SCRIT=1.0 SCRIT=MAX(SCRIT,0.0) ASIJ=0.0 SMIN=1.0 DO 175 J=ICB,JMAX IF(SIJ(I,J).GT.SIGMIN.AND.SIJ(I,J).LT.SIGMAX)THEN IF(J.GT.I)THEN SMID=MIN(SIJ(I,J),SCRIT) SJMAX=SMID SJMIN=SMID IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN SMIN=SMID SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT) SJMIN=MAX(SIJ(I,J-1),SIJ(I,J)) SJMIN=MIN(SJMIN,SCRIT) END IF ELSE SJMAX=MAX(SIJ(I,J+1),SCRIT) SMID=MAX(SIJ(I,J),SCRIT) SJMIN=0.0 IF(J.GT.1)SJMIN=SIJ(I,J-1) SJMIN=MAX(SJMIN,SCRIT) END IF DELP=ABS(SJMAX-SMID) DELM=ABS(SJMIN-SMID) ASIJ=ASIJ+(DELP+DELM)*(PH(J)-PH(J+1)) MENT(I,J)=MENT(I,J)*(DELP+DELM)*(PH(J)-PH(J+1)) END IF 175 CONTINUE ASIJ=MAX(1.0E-21,ASIJ) ASIJ=1.0/ASIJ DO 180 J=ICB,INB MENT(I,J)=MENT(I,J)*ASIJ 180 CONTINUE BSUM=0.0 DO 190 J=ICB,INB BSUM=BSUM+MENT(I,J) 190 CONTINUE IF(BSUM.LT.1.0E-18)THEN NENT(I)=0 MENT(I,I)=M(I) QENT(I,I)=Q(NK)-EP(I)*CLW(I) DO J=1,NTRA TRAENT(I,I,J)=TRA(NK,J) END DO ELIJ(I,I)=CLW(I) SIJ(I,I)=1.0 END IF END IF 200 CONTINUE C C *** CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING *** C *** DOWNDRAFT CALCULATION *** C IF(EP(INB).LT.0.0001)GOTO 405 C C *** INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER *** C *** AND CONDENSED WATER FLUX *** C JTT=2 C C *** BEGIN DOWNDRAFT LOOP *** C DO 400 I=INB,1,-1 C C *** CALCULATE DETRAINED PRECIPITATION *** C WDTRAIN=G*EP(I)*M(I)*CLW(I) IF(I.GT.1)THEN DO 320 J=1,I-1 AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I) AWAT=MAX(0.0,AWAT) 320 WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I) END IF C C *** FIND RAIN WATER AND EVAPORATION USING PROVISIONAL *** C *** ESTIMATES OF QP(I)AND QP(I-1) *** C c c *** Value of terminal velocity and coeffecient of evaporation for snow *** c COEFF=COEFFS WT(I)=OMTSNOW c c *** Value of terminal velocity and coeffecient of evaporation for rain *** c IF(T(I).GT.273.0)THEN COEFF=COEFFR WT(I)=OMTRAIN END IF QSM=0.5*(Q(I)+QP(I+1)) AFAC=COEFF*PH(I)*(QS(I)-QSM)/(1.0E4+2.0E3*PH(I)*QS(I)) AFAC=MAX(AFAC,0.0) SIGT=SIGP(I) SIGT=MAX(0.0,SIGT) SIGT=MIN(1.0,SIGT) B6=100.*(PH(I)-PH(I+1))*SIGT*AFAC/WT(I) C6=(WATER(I+1)*WT(I+1)+WDTRAIN/SIGD)/WT(I) REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6)) EVAP(I)=SIGT*AFAC*REVAP WATER(I)=REVAP*REVAP C C *** CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER *** C *** HYDROSTATIC APPROXIMATION *** C IF(I.EQ.1)GOTO 360 DHDP=(H(I)-H(I-1))/(P(I-1)-P(I)) DHDP=MAX(DHDP,10.0) MP(I)=100.*GINV*LV(I)*SIGD*EVAP(I)/DHDP MP(I)=MAX(MP(I),0.0) C C *** ADD SMALL AMOUNT OF INERTIA TO DOWNDRAFT *** C FAC=20.0/(PH(I-1)-PH(I)) MP(I)=(FAC*MP(I+1)+MP(I))/(1.+FAC) C C *** FORCE MP TO DECREASE LINEARLY TO ZERO *** C *** BETWEEN ABOUT 900 MB AND THE SURFACE *** C IF(P(I).GT.(0.899*P(1)))THEN JTT=MAX(JTT,I) MP(I)=MP(JTT)*(P(1)-P(I))/(P(1)-P(JTT)) END IF 360 CONTINUE C C *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT *** C IF(I.EQ.INB)GOTO 400 IF(I.EQ.1)THEN QSTM=QS(1) ELSE QSTM=QS(I-1) END IF IF(MP(I).GT.MP(I+1))THEN RAT=MP(I+1)/MP(I) QP(I)=QP(I+1)*RAT+Q(I)*(1.0-RAT)+100.*GINV* 1 SIGD*(PH(I)-PH(I+1))*(EVAP(I)/MP(I)) DO J=1,NTRA TRAP(I,J)=TRAP(I+1,J)*RAT+TRAP(I,J)*(1.-RAT) END DO ELSE IF(MP(I+1).GT.0.0)THEN QP(I)=(GZ(I+1)-GZ(I)+QP(I+1)*(LV(I+1)+T(I+1)*( 1 CL-CPD))+CPD*(T(I+1)-T(I)))/(LV(I)+T(I)*(CL-CPD)) DO J=1,NTRA TRAP(I,J)=TRAP(I+1,J) END DO END IF END IF QP(I)=MIN(QP(I),QSTM) QP(I)=MAX(QP(I),0.0) 400 CONTINUE C C *** CALCULATE SURFACE PRECIPITATION IN MM/DAY *** C PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G) C 405 CONTINUE C C *** CALCULATE DOWNDRAFT VELOCITY SCALE AND SURFACE TEMPERATURE AND *** c *** WATER VAPOR FLUCTUATIONS *** C WD=BETA*ABS(MP(ICB))*0.01*RD*T(ICB)/(SIGD*P(ICB)) QPRIME=0.5*(QP(1)-Q(1)) TPRIME=LV0*QPRIME/CPD C C -- ke 8/04 C C *** Calculate in-cloud horizontal velocities and fluxes *** C ICBM=MAX(ICB,3) C IF(INB.GE.ICBM)THEN C DO I=ICBM,INB AMP1=0.0 IF(I.GE.NK)THEN DO K=I,INB AMP1=AMP1+M(K) END DO END IF DO K=1,I DO J=I,INB AMP1=AMP1+MENT(K,J) END DO END DO DO K=1,I-1 DO J=I,INB AMP1=AMP1-MENT(J,K) END DO END DO AMPN=MAX(AMP1,0.0) AMP1=MAX(AMP1,1.0E-4) C CHIZ=50.*(PH(I-1)-PH(I+1))*LAMBDA/(AMP1*G) CHIU=CHIZ*ABS(UC(I-1)-UH(I-1)) UC(I)=(UC(I-2)*(1.-CHIU)+CHIU*(UH(I)+UH(I-2)))/(1.+CHIU) UC(I-1)=UC(I-1)+0.4*(UC(I)+UC(I-2)-2.*UC(I-1)) FLUXU(I-1)=AMPN*(UC(I-1)-UH(I-1)) CHIV=CHIZ*ABS(VC(I-1)-VH(I-1)) VC(I)=(VC(I-2)*(1.-CHIV)+CHIV*(VH(I)+VH(I-2)))/(1.+CHIV) VC(I-1)=VC(I-1)+0.4*(VC(I)+VC(I-2)-2.*VC(I-1)) FLUXV(I-1)=AMPN*(VC(I-1)-VH(I-1)) END DO IF(ICB.GT.(NK+1))THEN DO I=NK+1,ICB-1 DFAC=FLOAT(I-NK)/FLOAT(ICB-NK) FLUXU(I)=FLUXU(ICB)*DFAC FLUXV(I)=FLUXV(ICB)*DFAC END DO END IF C END IF C C *** Calculate unsaturated downdraft momentum flux *** C IF(INB.GT.2)THEN C DO I=INB-2,1,-1 IF(MP(I+2).GT.0.0)THEN AMP1=MAX(MP(I+2),1.0E-4) CHIZ=50.*(PH(I+1)-PH(I+3))*LAMBDA/(G*AMP1) CHIU=CHIZ*ABS(UP(I+1)-UH(I+1)) UP(I)=(UP(I+2)*(1.-CHIU)+CHIU*(UH(I)+UH(I+2)))/(1.+CHIU) UP(I+1)=UP(I+1)+0.4*(UP(I)+UP(I+2)-2.*UP(I+1)) FLUXU(I+1)=FLUXU(I+1)-MP(I+2)*(UP(I+1)-UH(I+1)) CHIV=CHIZ*ABS(VP(I+1)-VH(I+1)) VP(I)=(VP(I+2)*(1.-CHIV)+CHIV*(VH(I)+VH(I+2)))/(1.+CHIV) VP(I+1)=VP(I+1)+0.4*(VP(I)+VP(I+2)-2.*VP(I+1)) FLUXV(I+1)=FLUXV(I+1)-MP(I+2)*(VP(I+1)-VH(I+1)) END IF END DO FLUXU(1)=-MP(2)*(UP(1)-UH(1)) FLUXV(1)=-MP(2)*(VP(1)-VH(1)) C END IF C C -- end of addition by ke 8/04 C C *** CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE *** C *** AND MIXING RATIO *** C DPINV=0.01/(PH(1)-PH(2)) AM=0.0 IF(NK.EQ.1)THEN DO 410 K=2,INB 410 AM=AM+M(K) END IF IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4 FT(1)=FT(1)+G*DPINV*AM*(T(2)-T(1)+(GZ(2)-GZ(1))/CPN(1)) FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1) FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(T(2)- 1 T(1))*DPINV/CPN(1) c FT(1)=FT(1)+0.01*SIGD*WT(1)*WATER(1)*RD*TV(1)/(PH(1)*CPN(1)) FQ(1)=FQ(1)+G*MP(2)*(QP(2)-Q(1))* 1 DPINV+SIGD*EVAP(1) FQDET(1)=FQ(1) FQ(1)=FQ(1)+G*AM*(Q(2)-Q(1))*DPINV FQSUB(1)=G*AM*(Q(2)-Q(1))*DPINV FU(1)=-G*DPINV*FLUXU(1) FV(1)=-G*DPINV*FLUXV(1) DO J=1,NTRA FTRA(1,J)=FTRA(1,J)+G*DPINV*(MP(2)*(TRAP(2,J)-TRA(1,J))+ 1 AM*(TRA(2,J)-TRA(1,J))) END DO AMDE=0.0 DO 415 J=2,INB FQ(1)=FQ(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-Q(1)) FQSUB(1)=FQSUB(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-Q(1)) DO K=1,NTRA FTRA(1,K)=FTRA(1,K)+G*DPINV*MENT(J,1)*(TRAENT(J,1,K)- 1 TRA(1,K)) END DO 415 CONTINUE C C *** CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO *** C *** AT LEVELS ABOVE THE LOWEST LEVEL *** C C *** FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES *** C *** THROUGH EACH LEVEL *** C DO 500 I=2,INB DPINV=0.01/(PH(I)-PH(I+1)) CPINV=1.0/CPN(I) AMP1=0.0 AD=0.0 IF(I.GE.NK)THEN c IF(I.GE.ICB-1)THEN DO 440 K=I+1,INB+1 440 AMP1=AMP1+M(K) END IF DO 450 K=1,I DO 450 J=I+1,INB+1 AMP1=AMP1+MENT(K,J) IF(I.GE.ICB)MUP(I)=AMP1 c MUP(I)=AMP1 450 CONTINUE IF((2.*G*DPINV*AMP1).GE.DELTI)THEN IFLAG=4 c CBMF=CBMFOLD-0.1*(2.*G*DPINV*AMP1*DELT-1.) c CBMF=MAX(CBMF,0.0) END IF DO 470 K=1,I-1 DO 470 J=I,INB AD=AD+MENT(J,K) MDOWN(I)=AD 470 CONTINUE FT(I)=FT(I)+G*DPINV*(AMP1*(T(I+1)-T(I)+(GZ(I+1)-GZ(I))* 1 CPINV)-AD*(T(I)-T(I-1)+(GZ(I)-GZ(I-1))*CPINV)) 2 -SIGD*LVCP(I)*EVAP(I) FT(I)=FT(I)+G*DPINV*MENT(I,I)*(HP(I)-H(I)+ 1 T(I)*(CPV-CPD)*(Q(I)-QENT(I,I)))*CPINV FT(I)=FT(I)+SIGD*WT(I+1)*(CL-CPD)*WATER(I+1)* 1 (T(I+1)-T(I))*DPINV*CPINV FQ(I)=FQ(I)+G*DPINV*(AMP1*(Q(I+1)-Q(I))- 1 AD*(Q(I)-Q(I-1))) C C -- added by ke 8/04 C C *** Momentum fluxes *** C FU(I)=-G*DPINV*(FLUXU(I)-FLUXU(I-1)) FV(I)=-G*DPINV*(FLUXV(I)-FLUXV(I-1)) C C -- end of addition C DO K=1,NTRA FTRA(I,K)=FTRA(I,K)+G*DPINV*(AMP1*(TRA(I+1,K)- 1 TRA(I,K))-AD*(TRA(I,K)-TRA(I-1,K))) END DO FQSUB(I)=FQ(I) DO 480 K=1,I-1 AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I) AWAT=MAX(AWAT,0.0) FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-Q(I)) FQDET(I)=G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-Q(I)) c -- sb: C (saturated updrafts resulting from mixing) QCOND(I)=QCOND(I)+(ELIJ(K,I)-AWAT) NQCOND(I)=NQCOND(I)+1. c sb -- DO J=1,NTRA FTRA(I,J)=FTRA(I,J)+G*DPINV*MENT(K,I)*(TRAENT(K,I,J)- 1 TRA(I,J)) END DO 480 CONTINUE DO 490 K=I,INB FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-Q(I)) FQDET(I)=FQDET(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-Q(I)) DO J=1,NTRA FTRA(I,J)=FTRA(I,J)+G*DPINV*MENT(K,I)*(TRAENT(K,I,J)- 1 TRA(I,J)) END DO 490 CONTINUE FQ(I)=FQ(I)+SIGD*EVAP(I)+G*(MP(I+1)* 1 (QP(I+1)-Q(I))-MP(I)*(QP(I)-Q(I-1)))*DPINV FQDET(I)=FQDET(I)+SIGD*EVAP(I)+G*(MP(I+1)* 1 (QP(I+1)-Q(I))-MP(I)*(QP(I)-Q(I-1)))*DPINV DO J=1,NTRA FTRA(I,J)=FTRA(I,J)+G*DPINV*(MP(I+1)*(TRAP(I+1,J)-TRA(I,J))- 1 MP(I)*(TRAP(I,J)-TRA(I-1,J))) END DO c -- sb: C (saturated downdrafts resulting from mixing) DO K=I+1,INB QCOND(I)=QCOND(I)+ELIJ(K,I) NQCOND(I)=NQCOND(I)+1. ENDDO C (particular case: no detraining level is found) IF (NENT(I).EQ.0) THEN QCOND(I)=QCOND(I)+(1-EP(I))*CLW(I) NQCOND(I)=NQCOND(I)+1. ENDIF IF (NQCOND(I).NE.0.) THEN QCOND(I)=QCOND(I)/NQCOND(I) ENDIF c sb -- 500 CONTINUE C C *** Adjust tendencies at top of convection layer to reflect *** C *** actual position of the level zero CAPE *** C FQOLD=FQ(INB) FQ(INB)=FQ(INB)*(1.-FRAC) FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PH(INB)-PH(INB+1))/ 1 (PH(INB-1)-PH(INB)))*LV(INB)/LV(INB-1) FTOLD=FT(INB) FT(INB)=FT(INB)*(1.-FRAC) FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PH(INB)-PH(INB+1))/ 1 (PH(INB-1)-PH(INB)))*CPN(INB)/CPN(INB-1) FUOLD=FU(INB) FU(INB)=FU(INB)*(1.-FRAC) FU(INB-1)=FU(INB-1)+FRAC*FUOLD*((PH(INB)-PH(INB+1))/ 1 (PH(INB-1)-PH(INB))) FVOLD=FV(INB) FV(INB)=FV(INB)*(1.-FRAC) FV(INB-1)=FV(INB-1)+FRAC*FVOLD*((PH(INB)-PH(INB+1))/ 1 (PH(INB-1)-PH(INB))) DO K=1,NTRA FTRAOLD=FTRA(INB,K) FTRA(INB,K)=FTRA(INB,K)*(1.-FRAC) FTRA(INB-1,K)=FTRA(INB-1,K)+FRAC*FTRAOLD*(PH(INB)-PH(INB+1))/ 1 (PH(INB-1)-PH(INB)) END DO C C *** Very slightly adjust tendencies to force exact *** C *** enthalpy, momentum and tracer conservation *** C ENTS=0.0 UAV=0.0 VAV=0.0 DO 680 I=1,INB ENTS=ENTS+(CPN(I)*FT(I)+LV(I)*FQ(I))*(PH(I)-PH(I+1)) UAV=UAV+FU(I)*(PH(I)-PH(I+1)) VAV=VAV+FV(I)*(PH(I)-PH(I+1)) 680 CONTINUE ENTS=ENTS/(PH(1)-PH(INB+1)) UAV=UAV/(PH(1)-PH(INB+1)) VAV=VAV/(PH(1)-PH(INB+1)) DO 640 I=1,INB FT(I)=FT(I)-ENTS/CPN(I) FU(I)=FU(I)-UAV FV(I)=FV(I)-VAV 640 CONTINUE DO 700 K=1,NTRA TRAAV=0.0 DO 690 I=1,INB TRAAV=TRAAV+FTRA(I,K)*(PH(I)-PH(I+1)) 690 CONTINUE TRAAV=TRAAV/(PH(1)-PH(INB+1)) DO 695 I=1,INB FTRA(I,K)=FTRA(I,K)-TRAAV 695 CONTINUE 700 CONTINUE DO 750 I=1,INB DO 710 K=1,INB DET(I)=DET(I)+MENT(K,I) 710 CONTINUE DO 720 K=1,INB ENT(I)=ENT(I)+MENT(I,K) 720 CONTINUE ENT(I)=ENT(I)-MENT(I,I) 750 CONTINUE C In-cloud mixing ratio of condensed water : DO I=1,ND MA(I)=0.0 WA(I)=0.0 SIGA(I)=0.0 ENDDO DO I=NK,INB DO K=I+1,INB+1 MA(I)=MA(I)+M(K) ENDDO ENDDO DO I=ICB,INB-1 AX(I)=0. DO J=ICB,I AX(I)=AX(I)+RD*(TVP(J)-TV(J))*(PH(J)-PH(J+1))/P(J) ENDDO IF (AX(I).GT.0.) THEN WA(I)=SQRT(2.*AX(I)) ENDIF ENDDO DO I=1,NL IF (WA(I).GT.0. ) : SIGA(I)=MA(I)/WA(I)*RD*TVP(I)/P(I)/100./DELTA SIGA(I) = MIN(SIGA(I),1.0) QCONDC(I)=SIGA(I)*CLW(I)*(1.-EP(I)) : + (1.-SIGA(I))*QCOND(I) ENDDO C C *** RETURN *** C RETURN C END C C --------------------------------------------------------------------------- C SUBROUTINE TLIFT(P,T,Q,QS,GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK) REAL GZ(ND),TPK(ND),CLW(ND),P(ND) REAL T(ND),Q(ND),QS(ND),TVP(ND),LV0 C C *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS *** C CPD=1005.7 CPV=1870.0 CL=2500.0 RV=461.5 RD=287.04 LV0=2.501E6 C CPVMCL=CL-CPV EPS=RD/RV EPSI=1./EPS C C *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY *** C ALV=LV0-CPVMCL*(T(NK)-273.15) AH0=(CPD*(1.-Q(NK))+CL*Q(NK))*T(NK)+Q(NK)*ALV+GZ(NK) CPP=CPD*(1.-Q(NK))+Q(NK)*CPV CPINV=1./CPP C IF(KK.EQ.1)THEN C C *** CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE *** C DO 50 I=1,ICB-1 CLW(I)=0.0 50 CONTINUE DO 100 I=NK,ICB-1 TPK(I)=T(NK)-(GZ(I)-GZ(NK))*CPINV TVP(I)=TPK(I)*(1.+Q(NK)*EPSI) 100 CONTINUE END IF C C *** FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE *** C NST=ICB NSB=ICB IF(KK.EQ.2)THEN NST=NL NSB=ICB+1 END IF DO 300 I=NSB,NST TG=T(I) QG=QS(I) ALV=LV0-CPVMCL*(T(I)-273.15) DO 200 J=1,2 S=CPD+ALV*ALV*QG/(RV*T(I)*T(I)) S=1./S AHG=CPD*TG+(CL-CPD)*Q(NK)*T(I)+ALV*QG+GZ(I) TG=TG+S*(AH0-AHG) TG=MAX(TG,35.0) TC=TG-273.15 DENOM=243.5+TC IF(TC.GE.0.0)THEN ES=6.112*EXP(17.67*TC/DENOM) ELSE ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG)) END IF QG=EPS*ES/(P(I)-ES*(1.-EPS)) 200 CONTINUE ALV=LV0-CPVMCL*(T(I)-273.15) TPK(I)=(AH0-(CL-CPD)*Q(NK)*T(I)-GZ(I)-ALV*QG)/CPD CLW(I)=Q(NK)-QG CLW(I)=MAX(0.0,CLW(I)) RG=QG/(1.-Q(NK)) TVP(I)=TPK(I)*(1.+RG*EPSI) 300 CONTINUE RETURN END C SUBROUTINE CLOUDS_SUB_LS_40(ND,R,RS,T,P,PH,DT,QSUBGRID : ,CLDF,CLDQ,PRADJ,FTADJ,FRADJ,SIGSUB) implicit none C C========================================================================== C C CLOUDS_SUB_LS version 4.0 C C Purpose: C -------- C C 1) Call of the cloud parameterization C C 2) Large-scale super-saturation adjustment: C - condense water that exceeds saturation C - precipitate a fraction of that condensed water C - adjust the final in-cloud water content C C Inputs: C ------- C ND----------: Number of vertical levels C R--------ND-: Grid-box average of the total water mixing ratio [kg/kg] C RS-------ND-: Mean saturation humidity mixing ratio within the gridbox [kg/kg] C T--------ND-: Grid-box average temperature [K] C P-------ND+1: Pressure at mid-levels [mb] C PH------ND+1: Pressure at interface levels [mb] C DT----------: Timestep [seconds] C QSUBGRID-ND-: in-cloud mixing ratio of cloud condensate [kg/kg] from CONVECT C C Outputs: C -------- C CLDF-----ND-: cloud fraction [0-1] C CLDQ-----ND-: in-cloud mixing ratio of condensed water [kg/kg] C PRADJ----ND-: precipitation associated with the LS super-saturation [mm/day] C FTADJ----ND-: temperature tendency associated with the LS adjustment [K/s] C FRADJ----ND-: total water tendency associated with the LS adjustment [kg/kg/s] C SIGSUB---ND-: SQRT(variance) of total water [kg/kg] (diagnostic only) C C Written by: C ----------- C Sandrine Bony (MIT & LMD/CNRS) - August 1999 C C Modified by: C ------------ C C============================================================================ integer NA,ND,I parameter (NA=50) real DT, PRADJ real TCA,ELACRIT,ALV,CPN,TNEW,RNEW,EP real R(ND),RS(ND),T(ND),P(ND),PH(ND+1) : ,QSUBGRID(ND),CLDF(ND),CLDQ(ND) : ,FTADJ(ND),FRADJ(ND),RNEWLS(NA),TNEWLS(NA),QLSP(NA) : ,EPLS(NA) c a retirer dans version pub: real RSSURF,CLDL(NA),CLDA(NA),CLDK(NA),CLDS(NA) real BIDON(ND) real SIGSUB(ND) COMMON / cldpara / CLDL, CLDA, CLDK, CLDS C-------------------------------------------------------------------- C Thermodynamical constants: C REAL CPD,CPV,CL,RD,RV,LV0,G,ROWL,EPS,EPSI,CPVMCL PARAMETER (CPD=1005.7, CPV=1870.0, CL=2500.0, RD=287.04) PARAMETER (RV=461.5, LV0=2.501E6, G=9.8, ROWL=1000.0 ) PARAMETER (EPS=RD/RV, EPSI=1./EPS, CPVMCL=CL-CPV) C-------------------------------------------------------------------- C Microphysical parameters: C (here, we use the same values as in the convection scheme) C REAL TLCRIT,ELCRIT,EPMAX PARAMETER (TLCRIT=-55.0, ELCRIT=0.0011, EPMAX=0.999) C-------------------------------------------------------------------- C Initialize output arrays C PRADJ=0.0 C DO I = 1, ND FRADJ(I) = 0.0 FTADJ(I) = 0.0 TNEWLS(I) = T(I) RNEWLS(I) = R(I) QLSP(I) = 0.0 EPLS(I) = 0.0 BIDON(I) = 0.0 ! used for all-or-nothing only SIGSUB(I) = 0.0 ENDDO C------------------------------------------------------------------- C If the cloud parameterization has a "convective" type of closure, C then compute precipitation efficiencies associated with C large-scale precipitation (independent on the presence of C subgrid-scale variability), and then compute the cloud C fraction and in-cloud water content associated with the C combination of subgrid+large-scale condensation. C C DO 9999 I = ND, 1, -1 C C Calculate large-scale condensation and precipitation: C IF(R(I).GT.RS(I))THEN C C Precipitation efficiencies: C EP=0.0 TCA=T(I)-273.15 IF(TCA.GE.0.0)THEN ELACRIT=ELCRIT ELSE ELACRIT=ELCRIT*(1.0-TCA/TLCRIT) END IF ELACRIT=MAX(ELACRIT,0.0) EP= EPMAX * (1.0-ELACRIT/MAX(R(I)-RS(I),1.0E-8)) EP=MAX(EP,0.0) EP=MIN(EP,EPMAX) EPLS(I) = EP ! large-scale precipitation efficiency QLSP(I) = EP*(R(I)-RS(I)) ! precipitated cloud water C C Adjust temperature and humidity profiles: C TCA=T(I)-273.15 ALV=LV0-CPVMCL*TCA CPN=CPD*(1.-R(I))+CPV*R(I) TNEW=(ALV*(EP*R(I)+RS(I)*(ALV/(RV*T(I))-EP)) : +CPN*T(I))/ 1 (CPN+ALV*ALV*RS(I)/(RV*T(I)*T(I))) RNEW=RS(I)*(1.+(TNEW-T(I))*ALV/(RV*T(I)*T(I))) : + (1.-EP)*(R(I)-RS(I)) TNEWLS(I) = TNEW RNEWLS(I) = RNEW FRADJ(I)=FRADJ(I)+(RNEW-R(I))/DT FTADJ(I)=FTADJ(I)-ALV*(RNEW-R(I))/DT/CPN PRADJ=PRADJ-100.0*(PH(I)-PH(I+1))*(RNEW-R(I))/DT : *1000.0*3600.0*24.0/(ROWL*G) END IF ! R>RS 9999 CONTINUE C------------------------------------------------------------- C Cloud parameterization: C c GNO PDF and convect-closure: CALL CLOUDS_GNO_40(ND,R,RS,QSUBGRID,CLDF,CLDQ) C-------------------------------------------------------------------- C Remove large-scale precipitation from the cloud water content: C DO I = 1, ND CLDQ(I) = CLDQ(I) - QLSP(I) ENDDO RETURN END C SUBROUTINE CLOUDS_GNO_40(ND,R,RS,QSUB,CLDF,CLDQ) IMPLICIT NONE C C=================================================================================== C C CLOUDS_GNO version 4.0 C C Purpose: C -------- C C Parameterization of the cloudiness (cloud amount, cloud water content) C associated with cumulus convection. C C Principle: C ---------- C C This cloud parameterization predicts the cloudiness that is associated with C the presence of condensation within a large-scale domain: this condensation C may be produced at the subgrid-scale by cumulus convection and at the C large-scale by super-saturation. C C IMPORTANT: in the present version of the scheme, the only source of subgrid-scale C condensation that is considered is cumulus convection (condensation associated C with boundary layer turbulence, for instance, is not considered). C C The cloud fraction and the in-cloud water content are predicted by a C statistical approach. The subgrid-scale variability of total water C (vapor + condensed) within the gridbox is described by a generalized C log-normal Probability Distribution Function (PDF) whose mean, variance C and skewness coefficient are predicted. The predictors are: C 1) the local concentration of condensed water that is produced at C the subgrid-scale by convection (output of the convection scheme) C 2) the saturation deficit or excess of the environment C 3) the domain-averaged mixing ratio of total water C Note that we impose the distribution of total water to be bounded by zero. C On the other hand, no upper bound of the distribution is considered in this C version of the scheme. C C If no subgrid-scale condensation occurs within the domain, the scheme C becomes equivalent to an "all-or-nothing" large-scale saturation scheme. C C Inputs: C ------- C C ND----------: Number of vertical levels C R--------ND-: Domain-averaged mixing ratio of total water C RS-------ND-: Mean saturation humidity mixing ratio within the gridbox C QSUB-----ND-: Mixing ratio of condensed water within clouds associated C with SUBGRID-SCALE condensation processes (here, it is C predicted by the convection scheme) C Outputs: C -------- C C CLDF-----ND-: cloud fractional area (0-1) C CLDQ-----ND-: in-cloud mixing ratio of condensed water (kg/kg) C C CALL command: C ------------- C C CALL CLOUDS_GNO(ND,R,RS,QSUBGRID,CLDF,CLDQ) C C Reference: C ---------- C C Bony, S and K A Emanuel, 2001: A parameterization of the cloudiness C associated with cumulus convection; Evaluation using TOGA COARE data. C J. Atmos. Sci., accepted. C C Written by: C ----------- C C Sandrine Bony (MIT & LMD/CNRS; bony@wind.mit.edu) - July 2000 C C Difference with version 1.0: C numerical method of resolution of equation 9 C version 1.0: use a Gaussian PDF when erf(v)->1 C version 2.0: use an asymptotic expression of erf(v) instead of a Gaussian PDF C===================================================================================== c c -- input/output arguments of the subroutine: INTEGER ND REAL R(ND), RS(ND), QSUB(ND), CLDF(ND), CLDQ(ND) REAL alpha, lambda, kew, skew, sigs c -- lower bound of the PDF of total water: c REAL PB PARAMETER ( PB = 0.0 ) c c -- parameters controlling the iteration: c -- nmax : maximum nb of iterations (hopefully never reached!) c -- epsilon : accuracy of the numerical resolution (here 2.0%) c -- vmax : v-value above which we use an asymptotic expression for ERF(v) INTEGER nmax, niter PARAMETER ( nmax = 10) REAL epsilon, vmax0, vmax PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) c -- gardes-fou: REAL min_mu, min_Q PARAMETER ( min_mu = 1.e-12, min_Q=1.e-12 ) c -- misc: INTEGER K, n, m REAL*8 mu, qsat, delta, beta REAL*8 xx, aux, coeff, block, dist, fprime, det REAL*8 pi, u, v, erfu, erfv, xx1, xx2, erfg LOGICAL lconv c ---------------------------------------------------------------------------------- c ---------------------------------------------------------------------------------- pi = ACOS(-1.) c c -- loop over vertical levels : c DO 500 K = 1, ND c mu = R(K) mu = MAX(mu,min_mu) qsat = RS(K) qsat = MAX(qsat,min_mu) delta = log(mu/qsat) IF ( QSUB(K) .lt. min_Q ) THEN C=========================================================================== C If no condensation is produced at the subgrid-scale: C C -> the scheme becomes equivalent to a "large-scale condensation scheme" C ie: cldf = H(mu-qsat) and cldq = (mu-qsat)*H(mu-qsat) C where H is the Heaviside function. C (in the absence of subgrid-scale condensation, the generalized C log-normal PDF becomes equivalent to a gaussian PDF of variance C zero, i.e. it becomes equivalent to a Dirac function and the C cumulative distribution function becomes an Heaviside function). C=========================================================================== CLDQ(K) = MAX( 0.0, mu-qsat ) CLDF(K) = CLDQ(K) / MAX( CLDQ(K), min_mu ) lambda = mu alpha = 0.0 kew = 0.0 skew = 0.0 sigs = 0.0 ELSE C=========================================================================== C Some condensation is produced at the subgrid-scale: C (presence of subgrid-scale variability): C C Use the (iterative) numerical method of Newton to determine the parameters C that characterize the PDF of total water. C C Remark 1: the accuracy of the resolution is controlled by "epsilon" C Remark 2: in GCMs, this numerical method may be too much CPU-time consuming. C In that case, it may be more appropriate to substitute it by a tabulation C of equations 9 and 11 (see the Bony-Emanuel article cited in introduction). C=========================================================================== lconv = .FALSE. ! flag for numerical convergence niter = 0 c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c PDF = generalized log-normal distribution (GNO): c (k<0 if a lower bound is considered for the PDF of total water) c c -> determine x (the parameter k of the GNO PDF) c such that the contribution of subgrid-scale processes to the c in-cloud water content is equal to QSUB(K) c c NB: the "error function" is called ERF or DERF (in double precision) c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ beta = QSUB(K)/mu + EXP( -MIN(0.0,delta) ) vmax = vmax0 IF ( .NOT. lconv ) then ! new c -- roots of equation v > vmax: det = delta + vmax**2. if (det.LE.0.0) vmax = vmax0 + 1.0 det = delta + vmax**2. if (det.LE.0.) then xx = -0.0001 else xx1 = -SQRT(2.)*vmax*(1.0-SQRT(1.0+delta/(vmax**2.))) xx2 = -SQRT(2.)*vmax*(1.0+SQRT(1.0+delta/(vmax**2.))) xx = 1.01 * xx1 if ( xx1 .GE. 0.0 ) xx = 0.5*xx2 endif if (delta.LT.0.) : xx = -0.5*SQRT(log(2.)) ! test comme avant DO n = 1, nmax ! iteration loop u = delta/(xx*sqrt(2.)) + xx/(2.*sqrt(2.)) v = delta/(xx*sqrt(2.)) - xx/(2.*sqrt(2.)) IF ( v .GT. vmax ) THEN IF ( ABS(u) .GT. vmax : .AND. delta .LT. 0. ) THEN c -- use asymptotic expression of erf for u and v large: c ( -> analytic solution for xx ) aux = 2.0*delta*(1.-beta*EXP(delta)) : /(1.+beta*EXP(delta)) xx = -SQRT(aux) block = EXP(-v*v) / v / sqrt(pi) dist = 0.0 fprime = 1.0 ELSE c -- erfv -> 1.0, use an asymptotic expression of erfv for v large: erfu = ERFG(u) aux = sqrt(pi) * (1.0-erfu) * EXP(v*v) coeff = 1.0 - 1./2./(v**2.) + 3./4./(v**4.) block = coeff * EXP(-v*v) / v / sqrt(pi) dist = v * aux / coeff - beta fprime = 2.0 / xx * (v**2.) : * ( coeff*EXP(-delta) - u * aux ) : / coeff / coeff ENDIF ! ABS(u) ELSE c -- general case: erfu = ERFG(u) erfv = ERFG(v) block = 1.0-erfv dist = (1.0 - erfu) / (1.0 - erfv) - beta fprime = 2. /sqrt(pi) /xx /(1.0-erfv)**2. : * ( (1.0-erfv)*v*EXP(-u*u) : - (1.0-erfu)*u*EXP(-v*v) ) ENDIF ! x c -- numerical convergence reached? if ( ABS(dist/beta) .LT. epsilon ) then ! convergence lconv = .TRUE. ! numerical convergence reached with GNO PDF ccc write(*,*) 'CV NEWTON GNO FOR K, N = ',K,n c parameters that characterize the PDF: kew = xx aux = EXP(kew*kew) sigs = mu * SQRT( aux-1.0 ) sigs = MAX(sigs,0.0) lambda = mu / SQRT (aux) alpha = - lambda * kew skew = ( 2.0 + aux**3. - 3*aux ) * (mu/sigs)**3. c deduce the cloud fraction and the in-cloud water content: c -------------------------------------------------------------- CLDF(K) = 0.5 * block CLDQ(K) = QSUB(K) + MAX(mu-qsat,0.0) GOTO 100 else xx = xx - dist/fprime endif ENDDO ! n 100 continue if (.NOT. lconv) then write(*,*) 'NO CV in CLOUDS_GNO: K,mu,qsub,qsat,n,niter: ' : ,K,mu*1000.,QSUB(K)*1000.,qsat*1000.,n,niter write(*,*) 'gamma,beta,error = ',delta,beta,ABS(dist/beta) c all-or-nothing scheme in that (exceptional) case, may be improved later on: CLDQ(K) = MAX( 0.0, mu-qsat ) CLDF(K) = CLDQ(K) / MAX( CLDQ(K), min_mu ) endif ENDIF ! lconv ENDIF ! qsub 500 CONTINUE ! K RETURN END C function erfc(x) parameter( & pv= 9.20888710e+00, & ph= 5.07254732e+00, & p0= 3.86642217e-01, & p1= 1.52430177e-01, & p2= 2.38149125e-02, & p3= 1.30227291e-03, & q0= 1.16381965e-01, & q1= 1.04753802e+00, & q2= 2.92132156e+00, & q3= 6.02608434e+00) y=x*x y=exp(-y)*x*(p3/(y+q3)+p2/(y+q2) & +p1/(y+q1)+p0/(y+q0)) if(x.lt.ph) y=y+2/(exp(pv*x)+1) erfc=y end ! ! error function in double precision ! function erfg(x) implicit real*8 (a - h, o - z) dimension a(0 : 64), b(0 : 64) data (a(i), i = 0, 12) / & 0.00000000005958930743d0, -0.00000000113739022964d0, & 0.00000001466005199839d0, -0.00000016350354461960d0, & 0.00000164610044809620d0, -0.00001492559551950604d0, & 0.00012055331122299265d0, -0.00085483269811296660d0, & 0.00522397762482322257d0, -0.02686617064507733420d0, & 0.11283791670954881569d0, -0.37612638903183748117d0, & 1.12837916709551257377d0 / data (a(i), i = 13, 25) / & 0.00000000002372510631d0, -0.00000000045493253732d0, & 0.00000000590362766598d0, -0.00000006642090827576d0, & 0.00000067595634268133d0, -0.00000621188515924000d0, & 0.00005103883009709690d0, -0.00037015410692956173d0, & 0.00233307631218880978d0, -0.01254988477182192210d0, & 0.05657061146827041994d0, -0.21379664776456006580d0, & 0.84270079294971486929d0 / data (a(i), i = 26, 38) / & 0.00000000000949905026d0, -0.00000000018310229805d0, & 0.00000000239463074000d0, -0.00000002721444369609d0, & 0.00000028045522331686d0, -0.00000261830022482897d0, & 0.00002195455056768781d0, -0.00016358986921372656d0, & 0.00107052153564110318d0, -0.00608284718113590151d0, & 0.02986978465246258244d0, -0.13055593046562267625d0, & 0.67493323603965504676d0 / data (a(i), i = 39, 51) / & 0.00000000000382722073d0, -0.00000000007421598602d0, & 0.00000000097930574080d0, -0.00000001126008898854d0, & 0.00000011775134830784d0, -0.00000111992758382650d0, & 0.00000962023443095201d0, -0.00007404402135070773d0, & 0.00050689993654144881d0, -0.00307553051439272889d0, & 0.01668977892553165586d0, -0.08548534594781312114d0, & 0.56909076642393639985d0 / data (a(i), i = 52, 64) / & 0.00000000000155296588d0, -0.00000000003032205868d0, & 0.00000000040424830707d0, -0.00000000471135111493d0, & 0.00000005011915876293d0, -0.00000048722516178974d0, & 0.00000430683284629395d0, -0.00003445026145385764d0, & 0.00024879276133931664d0, -0.00162940941748079288d0, & 0.00988786373932350462d0, -0.05962426839442303805d0, & 0.49766113250947636708d0 / data (b(i), i = 0, 12) / & -0.00000000029734388465d0, 0.00000000269776334046d0, & -0.00000000640788827665d0, -0.00000001667820132100d0, & -0.00000021854388148686d0, 0.00000266246030457984d0, & 0.00001612722157047886d0, -0.00025616361025506629d0, & 0.00015380842432375365d0, 0.00815533022524927908d0, & -0.01402283663896319337d0, -0.19746892495383021487d0, & 0.71511720328842845913d0 / data (b(i), i = 13, 25) / & -0.00000000001951073787d0, -0.00000000032302692214d0, & 0.00000000522461866919d0, 0.00000000342940918551d0, & -0.00000035772874310272d0, 0.00000019999935792654d0, & 0.00002687044575042908d0, -0.00011843240273775776d0, & -0.00080991728956032271d0, 0.00661062970502241174d0, & 0.00909530922354827295d0, -0.20160072778491013140d0, & 0.51169696718727644908d0 / data (b(i), i = 26, 38) / & 0.00000000003147682272d0, -0.00000000048465972408d0, & 0.00000000063675740242d0, 0.00000003377623323271d0, & -0.00000015451139637086d0, -0.00000203340624738438d0, & 0.00001947204525295057d0, 0.00002854147231653228d0, & -0.00101565063152200272d0, 0.00271187003520095655d0, & 0.02328095035422810727d0, -0.16725021123116877197d0, & 0.32490054966649436974d0 / data (b(i), i = 39, 51) / & 0.00000000002319363370d0, -0.00000000006303206648d0, & -0.00000000264888267434d0, 0.00000002050708040581d0, & 0.00000011371857327578d0, -0.00000211211337219663d0, & 0.00000368797328322935d0, 0.00009823686253424796d0, & -0.00065860243990455368d0, -0.00075285814895230877d0, & 0.02585434424202960464d0, -0.11637092784486193258d0, & 0.18267336775296612024d0 / data (b(i), i = 52, 64) / & -0.00000000000367789363d0, 0.00000000020876046746d0, & -0.00000000193319027226d0, -0.00000000435953392472d0, & 0.00000018006992266137d0, -0.00000078441223763969d0, & -0.00000675407647949153d0, 0.00008428418334440096d0, & -0.00017604388937031815d0, -0.00239729611435071610d0, & 0.02064129023876022970d0, -0.06905562880005864105d0, & 0.09084526782065478489d0 / w = abs(x) if (w .lt. 2.2d0) then t = w * w k = int(t) t = t - k k = k * 13 y = ((((((((((((a(k) * t + a(k + 1)) * t + & a(k + 2)) * t + a(k + 3)) * t + a(k + 4)) * t + & a(k + 5)) * t + a(k + 6)) * t + a(k + 7)) * t + & a(k + 8)) * t + a(k + 9)) * t + a(k + 10)) * t + & a(k + 11)) * t + a(k + 12)) * w else if (w .lt. 6.9d0) then k = int(w) t = w - k k = 13 * (k - 2) y = (((((((((((b(k) * t + b(k + 1)) * t + & b(k + 2)) * t + b(k + 3)) * t + b(k + 4)) * t + & b(k + 5)) * t + b(k + 6)) * t + b(k + 7)) * t + & b(k + 8)) * t + b(k + 9)) * t + b(k + 10)) * t + & b(k + 11)) * t + b(k + 12) y = y * y y = y * y y = y * y y = 1 - y * y else y = 1 end if if (x .lt. 0) y = -y erfg = y end ! C SUBROUTINE OPTICAL(ND,T,PH,P,CLDF,CLDQ : ,CLDEMI,CLDTAU,CLDFICE,CLDT,CLDWP) implicit none C============================================================================ C Purpose: C ----------- C Compute cloud optical properties (emissivity, optical thickness) C C CALL command: C ------------- C CALL OPTICAL(NA,T2,PH,P,CLDF,CLDQ,CLDEMI,CLDTAU,CLDFICE,CLDT,CLDWP) C C Inputs: C ----------- C ND-----------: Number of vertical levels C T--------ND--: Grid-box average temperature (K) C PH-------ND+1: Pressure at interface levels (Pa) C P--------ND--: Pressure at mid-levels (Pa) C CLDF-----ND--: Cloud fraction at each vertical level (0-1) C CLDQ-----ND--: In-cloud condensate mixing ratio (kg/kg) C C Outputs: C ----------- C CLDEMI---ND--: Cloud longwave emissivity C CLDTAU---ND--: Cloud optical thickness C CLDFICE--ND--: Ice fraction within the grid-box C CLDT------1--: Total cloud cover C CLDWP-----1--: Gridbox averaged cloud water path (kg/m2) C C Author & date: C --------------- C Sandrine Bony (MIT & LMD/CNRS) - June 1999 C C Modification Feb 2000: if newmicro=TRUE, use cloud microphysical properties C suggested by Iacobellis and Somerville (1999) for C rad_liq and rad_ice, and by Ebert and Curry (1992) C for coef_liq and coef_ice. C C Caution: if newmicro=TRUE and if this routine is used in a GCM, information C about the surface (land or ocean) should be used to specify the C droplet concentration (Noc or Nland); for the moment we C assume that this is an ocean surface. C C============================================================================ C integer ND,k,i,n,no real T(ND),CLDF(ND),CLDQ(ND),CLDEMI(ND),CLDTAU(ND) : ,PH(ND+1),P(ND),CLDFICE(ND),CLDT,CLDWP c c -- equivalent cloud droplet radius for liquid/ice clouds: real radius, rad_ice, rad_liq parameter (rad_liq=10.0, rad_ice=30.0) c c -- IR absorption coefficient for liquid/ice clouds (includes c the diffusivity factor): real coef, coef_ice, coef_liq parameter (coef_liq=0.13, coef_ice=0.09) c c -- Thresholds for liquid/ice clouds distinction: real seuil_neb, T_ice, T_o parameter (seuil_neb=0.001) c from LMD ("CTRL" and "ICE-OPT" expts): parameter (T_o=273.15, T_ice=273.15-15.0) c Zender and Kiehl (95): ("PHASE" expt) c parameter (T_o=273.15-10, T_ice=273.15-30.0) c c -- for the new microphysical parameterization: real Noc, Nland ! droplet nb concentration (cm^{-3}) parameter (Noc=150., Nland=600.)! Bower et al. 1994 real k_liq, k_ice0, k_ice, DF, k0,k1,k2,k3 parameter (k_liq=0.0903, k_ice0=0.005) ! units = m2/g parameter (DF=1.66) ! diffusivity factor parameter (k0=60.75, k1=-2.47, k2=-0.11, k3=-0.001) real pi, aux, rel, rei, kabs, tc c -- Misc: real RG, undef, zflwp, zfiwp parameter (RG=9.8,undef=999.999) logical lo, newmicro parameter (newmicro=.FALSE.) !if T: new opt prop for ice clds, refnew c parameter (newmicro=.TRUE.) !if T: new opt prop for ice clds pi = ACOS(-1.) c c Cloud optical thickness and emissivity: c DO k = 1, ND CLDF(k) = MAX(CLDF(k), seuil_neb) c liquid/ice fraction: CLDFICE(k) = 1.0 - (T(k)-T_ice) / (T_o-T_ice) CLDFICE(k) = MIN(MAX(CLDFICE(k),0.0),1.0) c liquid/ice cloud water paths: zflwp = 1000.*(1.-CLDFICE(k))*CLDQ(k) : *(PH(k)-PH(k+1))/RG zfiwp = 1000.*CLDFICE(k)*CLDQ(k) : *(PH(k)-PH(k+1))/RG c optical properties: IF (newmicro) THEN c*********************************************************** c NB: "no" means that we modify only the optical properties c of ice clouds, not those of liquid clouds c*********************************************************** c -- parameterization of the effective cloud droplet radius (microns): c++++ for liquid water clouds: rel = rad_liq ! no c++++ for ice clouds: as a function of the ambiant temperature tc = T(k)-273.15 c ...... formula used by Iacobellis and Somerville (2000): c ...... (with an asymptotical value of 3.5 microns at T<-81.4 C c ...... added to be consistent with observations of Heymsfield et al. 1986): rei = 0.71*tc + 61.29 if (tc.le.-81.4) rei = 3.5 ! only micronew, phasenew expts c cloud optical thickness: c for liquid clouds, LMD-like, for ice clouds, Ebert & Curry (1992): c ------------------------------------------------------------------ if (zflwp.eq.0.) rel = 1. ! no influence if (zfiwp.eq.0. .or. rei.le.0.) rei = 1. ! no influence CLDTAU(k) = 3.0/2.0 * ( zflwp/rel ) . + zfiwp * (3.448e-03 + 2.431/rei) c cloud infrared emissivity: c --------------------------- c the broadband infrared absorption coefficient is parameterized as a c function of the effective cld droplet radius: c ... Ebert and Curry (1992) formula: c as used by Kiehl & Zender (1995): k_ice = k_ice0 + 1.0/rei ! iceopt c cloud emissivity: CLDEMI(k) = 1.0 . - EXP( - coef_liq*zflwp - DF*k_ice*zfiwp ) ELSE c -- version LMD: c --------------- CLDTAU(k) = 3.0/2.0 . * ( zflwp/rad_liq + zfiwp/rad_ice ) CLDEMI(k) = 1.0 . - EXP( - coef_liq*zflwp - coef_ice*zfiwp ) ENDIF ! newmicro lo = (CLDF(k) .LE. seuil_neb) IF (lo) CLDF(k) = 0.0 IF (lo) CLDTAU(k) = 0.0 IF (lo) CLDEMI(k) = 0.0 lo = (CLDQ(k) .EQ. undef) IF (lo) write(*,*) 'PB: CLDQ EQ UNDEF ' IF (lo) CLDTAU(k) = undef IF (lo) CLDEMI(k) = undef ENDDO C C Cloud liquid path and total cloudiness: C CLDT = 1. CLDWP = 0. no = 0 DO k = ND, 1, -1 if (CLDQ(k) .NE. undef .and. CLDF(k).ne.undef) then CLDWP = CLDWP . + CLDQ(k)*CLDF(k)*(PH(k)-PH(k+1))/RG CLDT = CLDT * (1.0-CLDF(k)) ! random overlap else no = 1 write(*,*) 'PB: k, CLDF, CLDQ: ',CLDF(k),CLDQ(k) endif ENDDO CLDT = 1.0 - CLDT ! random overlap only C if (no.eq.1) then CLDT = undef CLDWP = undef endif RETURN END c====================================================================== SUBROUTINE orbite(xjour,longi,dist) IMPLICIT none c====================================================================== c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818 c Objet: pour un jour donne, calculer la longitude vraie de la terre c (par rapport au point vernal-21 mars) dans son orbite solaire c calculer aussi la distance terre-soleil (unite astronomique) c====================================================================== c Arguments: c xjour--INPUT--R- jour de l'annee a compter du 1er janvier c longi--OUTPUT-R- longitude vraie en degres par rapport au point c vernal (21 mars) en degres c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne) REAL xjour, longi, dist c====================================================================== include "YOMCST.h" C C -- Variables dynamiques locales REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv C C -- sb: c call suphec to fill YOMSCT: call suphec C sb -- pir = 4.0*ATAN(1.0) / 180.0 xl=R_peri+180.0 xllp=xl*pir xee=R_ecc*R_ecc xse=SQRT(1.0-xee) xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp) . - xee/4.0*(0.5+xse)*SIN(2.0*xllp) . + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp) xlam=2.0*xlam/pir dlamm=xlam+(xjour-81.0) anm=dlamm-xl ranm=anm*pir xee=xee*R_ecc ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm) . +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm) . +13.0/12.0*xee*SIN(3.0*ranm) c anv=ranv/pir longi=anv+xl C dist = (1-R_ecc*R_ecc) . /(1+R_ecc*COS(pir*(longi-(R_peri+180.0)))) RETURN END c====================================================================== SUBROUTINE angle(longi, lati, frac, muzero) IMPLICIT none c====================================================================== c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur c du soleil (cosinus de l'angle zinithal) moyenne sur la journee c====================================================================== c Arguments: c longi----INPUT-R- la longitude vraie de la terre dans son plan c solaire a partir de l'equinoxe de printemps (degre) c lati-----INPUT-R- la latitude d'un point sur la terre (degre) c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee c par 24 heures (unite en fraction de 0 a 1) c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur c la journee (0 a 1) c====================================================================== include "dimensions.h" include "dimphy.h" REAL longi REAL lati(klon), frac(klon), muzero(klon) include "YOMCST.h" REAL lat, omega, lon_sun, lat_sun REAL pi_local, incl INTEGER i c pi_local = 4.0 * ATAN(1.0) incl=R_incl * pi_local / 180. c lon_sun = longi * pi_local / 180.0 lat_sun = ASIN (sin(lon_sun)*SIN(incl) ) c DO i = 1, klon lat = lati(i) * pi_local / 180.0 lat = lati(i) * pi_local / 180.0 c IF ( lat .GE. (pi_local/2.+lat_sun) . .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN omega = 0.0 ! nuit polaire ELSE IF ( lat.GE.(pi_local/2.-lat_sun) . .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN omega = pi_local ! journee polaire ELSE omega = -TAN(lat)*TAN(lat_sun) omega = ACOS (omega) ENDIF c frac(i) = omega / pi_local c IF (omega .GT. 0.0) THEN muzero(i) = SIN(lat)*SIN(lat_sun) . + COS(lat)*COS(lat_sun)*SIN(omega) / omega ELSE muzero(i) = 0.0 ENDIF ENDDO c RETURN END c==================================================================== SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long, s pmu0,frac) IMPLICIT none c============================================================= c Auteur : O. Boucher (LMD/CNRS) c d'apres les routines zenith et angle de Z.X. Li c Objet : calculer les valeurs moyennes du cos de l'angle zenithal c et l'ensoleillement moyen entre gmtime1 et gmtime2 c connaissant la declinaison, la latitude et la longitude. c Rque : Different de la routine angle en ce sens que zenang c fournit des moyennes de pmu0 et non des valeurs c instantanees, du coup frac prend toutes les valeurs c entre 0 et 1. c Date : premiere version le 13 decembre 1994 c revu pour GCM le 30 septembre 1996 c=============================================================== c longi----INPUT : la longitude vraie de la terre dans son plan c solaire a partir de l'equinoxe de printemps (degre) c gmtime---INPUT : temps universel en fraction de jour c pdtrad---INPUT : pas de temps du rayonnement (secondes) c lat------INPUT : latitude en degres c long-----INPUT : longitude en degres c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad c================================================================ include "dimensions.h" include "dimphy.h" include "YOMCST.h" c================================================================ real longi, gmtime, pdtrad real lat(klon), long(klon), pmu0(klon), frac(klon) c================================================================ integer i real gmtime1, gmtime2 real pi_local, deux_pi_local, incl real omega1, omega2, omega c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi. c omega : heure en radian du coucher de soleil c -omega est donc l'heure en radian de lever du soleil real omegadeb, omegafin real zfrac1, zfrac2, z1_mu, z2_mu real lat_sun ! declinaison en radian real lon_sun ! longitude solaire en radian real latr ! latitude du pt de grille en radian c================================================================ c pi_local = 4.0 * ATAN(1.0) deux_pi_local = 2.0 * pi_local incl=R_incl * pi_local / 180. c lon_sun = longi * pi_local / 180.0 lat_sun = ASIN (SIN(lon_sun)*SIN(incl) ) c gmtime1=gmtime*86400. gmtime2=gmtime*86400.+pdtrad c DO i = 1, klon c latr = lat(i) * pi_local / 180. c c--pose probleme quand lat=+/-90 degres c c omega = -TAN(latr)*TAN(lat_sun) c omega = ACOS(omega) c IF (latr.GE.(pi_local/2.+lat_sun) c . .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN c omega = 0.0 ! nuit polaire c ENDIF c IF (latr.GE.(pi_local/2.-lat_sun) c . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN c omega = pi_local ! journee polaire c ENDIF c c--remplace par cela (le cas par defaut est different) c omega=0.0 !--nuit polaire IF (latr.GE.(pi_local/2.-lat_sun) . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN omega = pi_local ! journee polaire ENDIF IF (latr.LT.(pi_local/2.+lat_sun).AND. . latr.GT.(-pi_local/2.+lat_sun).AND. . latr.LT.(pi_local/2.-lat_sun).AND. . latr.GT.(-pi_local/2.-lat_sun)) THEN omega = -TAN(latr)*TAN(lat_sun) omega = ACOS(omega) ENDIF c omega1 = gmtime1 + long(i)*86400.0/360.0 omega1 = omega1 / 86400.0*deux_pi_local omega1 = MOD (omega1+deux_pi_local, deux_pi_local) omega1 = omega1 - pi_local c omega2 = gmtime2 + long(i)*86400.0/360.0 omega2 = omega2 / 86400.0*deux_pi_local omega2 = MOD (omega2+deux_pi_local, deux_pi_local) omega2 = omega2 - pi_local c IF (omega1.LE.omega2) THEN !--on est dans la meme journee locale c IF (omega2.LE.-omega .OR. omega1.GE.omega . .OR. omega.LT.1e-5) THEN !--nuit frac(i)=0.0 pmu0(i)=0.0 ELSE !--jour+nuit/jour omegadeb=MAX(-omega,omega1) omegafin=MIN(omega,omega2) frac(i)=(omegafin-omegadeb)/(omega2-omega1) pmu0(i)=SIN(latr)*SIN(lat_sun) + . COS(latr)*COS(lat_sun)* . (SIN(omegafin)-SIN(omegadeb))/ . (omegafin-omegadeb) ENDIF c ELSE !---omega1 GT omega2 -- a cheval sur deux journees c c-------------------entre omega1 et pi IF (omega1.GE.omega) THEN !--nuit zfrac1=0.0 z1_mu =0.0 ELSE !--jour+nuit omegadeb=MAX(-omega,omega1) omegafin=omega zfrac1=omegafin-omegadeb z1_mu =SIN(latr)*SIN(lat_sun) + . COS(latr)*COS(lat_sun)* . (SIN(omegafin)-SIN(omegadeb))/ . (omegafin-omegadeb) ENDIF c---------------------entre -pi et omega2 IF (omega2.LE.-omega) THEN !--nuit zfrac2=0.0 z2_mu =0.0 ELSE !--jour+nuit omegadeb=-omega omegafin=MIN(omega,omega2) zfrac2=omegafin-omegadeb z2_mu =SIN(latr)*SIN(lat_sun) + . COS(latr)*COS(lat_sun)* . (SIN(omegafin)-SIN(omegadeb))/ . (omegafin-omegadeb) c ENDIF c-----------------------moyenne frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1) pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10) c ENDIF !---comparaison omega1 et omega2 c ENDDO c END c=================================================================== SUBROUTINE zenith (longi, gmtime, lat, long, s pmu0, fract) IMPLICIT none c c Auteur(s): Z.X. Li (LMD/ENS) c c Objet: calculer le cosinus de l'angle zenithal du soleil en c connaissant la declinaison du soleil, la latitude et la c longitude du point sur la terre, et le temps universel c c Arguments d'entree: c longi : declinaison du soleil (en degres) c gmtime : temps universel en second qui varie entre 0 et 86400 c lat : latitude en degres c long : longitude en degres c Arguments de sortie: c pmu0 : cosinus de l'angle zenithal c c==================================================================== include "dimensions.h" include "dimphy.h" include "YOMCST.h" c==================================================================== REAL longi, gmtime REAL lat(klon), long(klon), pmu0(klon), fract(klon) c===================================================================== INTEGER n REAL zpi, zpir, omega, zgmtime REAL incl, lat_sun, lon_sun c---------------------------------------------------------------------- zpi = 4.0*ATAN(1.0) zpir = zpi / 180.0 zgmtime=gmtime*86400. c incl=R_incl * zpir c lon_sun = longi * zpir lat_sun = ASIN (SIN(lon_sun)*SIN(incl) ) c c--initialisation a la nuit c DO n =1, klon pmu0(n)=0. fract(n)=0.0 ENDDO c c 1 degre en longitude = 240 secondes en temps c DO n = 1, klon omega = zgmtime + long(n)*86400.0/360.0 omega = omega / 86400.0 * 2.0 * zpi omega = MOD(omega + 2.0 * zpi, 2.0 * zpi) omega = omega - zpi pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun) . + cos(lat(n)*zpir) * cos(lat_sun) . * cos(omega) pmu0(n) = MAX (pmu0(n), 0.0) IF (pmu0(n).GT.1.E-6) fract(n)=1.0 ENDDO c RETURN END SUBROUTINE radlwsw(dist, rmu0, fract, co2_ppm, solaire, . paprs, pplay,tsol,albedo, t,q,wo, . cldfra, cldemi, cldtau, . heat,heat0,cool,cool0,radsol,albpla, . topsw,toplw,solsw,sollw, . topsw0,toplw0,solsw0,sollw0) IMPLICIT none c====================================================================== c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719 c Objet: interface entre le modele et les rayonnements c Arguments: c dist-----input-R- distance astronomique terre-soleil c rmu0-----input-R- cosinus de l'angle zenithal c fract----input-R- duree d'ensoleillement normalisee c co2_ppm--input-R- concentration du gaz carbonique (en ppm) c solaire--input-R- constante solaire (W/m**2) c paprs----input-R- pression a inter-couche (Pa) c pplay----input-R- pression au milieu de couche (Pa) c tsol-----input-R- temperature du sol (en K) c albedo---input-R- albedo du sol (entre 0 et 1) c t--------input-R- temperature (K) c q--------input-R- vapeur d'eau (en kg/kg) c wo-------input-R- contenu en ozone (en kg/kg) c cldfra---input-R- fraction nuageuse (entre 0 et 1) c cldtau---input-R- epaisseur optique des nuages dans le visible c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1) c c heat-----output-R- echauffement atmospherique (visible) (K/jour) c cool-----output-R- refroidissement dans l'IR (K/jour) c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas) c albpla---output-R- albedo planetaire (entre 0 et 1) c topsw----output-R- ray. solaire absorbe au sommet de l'atm. c toplw----output-R- ray. IR emis au sommet de l'atmosphere c solsw----output-R- ray. solaire net absorbe a la surface c sollw----output-R- ray. IR net emis par la surface c====================================================================== include "dimensions.h" include "dimphy.h" include "raddim.h" c real rmu0(klon), fract(klon), dist real co2_ppm real solaire c real paprs(klon,klev+1), pplay(klon,klev) real albedo(klon), tsol(klon) real t(klon,klev), q(klon,klev), wo(klon,klev) real cldfra(klon,klev), cldemi(klon,klev), cldtau(klon,klev) real heat(klon,klev), cool(klon,klev) real heat0(klon,klev), cool0(klon,klev) real radsol(klon), topsw(klon), toplw(klon) real solsw(klon), sollw(klon), albpla(klon) real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon) c REAL*8 zx_alpha1, zx_alpha2 c include "YOMCST.h" c INTEGER k, kk, i, j, iof, nb_gr EXTERNAL lw, sw c REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12 REAL*8 PSCT c REAL*8 PALBD(kdlon,2), PALBP(kdlon,2) REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon) REAL*8 PPSOL(kdlon), PDP(kdlon,klev) REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1) REAL*8 PTAVE(kdlon,kflev) REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev) REAL*8 PAER(kdlon,kflev,5) REAL*8 PCLDLD(kdlon,kflev) REAL*8 PCLDLU(kdlon,kflev) REAL*8 PCLDSW(kdlon,kflev) REAL*8 PTAU(kdlon,2,kflev) REAL*8 POMEGA(kdlon,2,kflev) REAL*8 PCG(kdlon,2,kflev) c REAL*8 zfract(kdlon), zrmu0(kdlon), zdist c REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev) REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev) REAL*8 ztopsw(kdlon), ztoplw(kdlon) REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon) REAL*8 ztopsw0(kdlon), ztoplw0(kdlon) REAL*8 zsolsw0(kdlon), zsollw0(kdlon) c c------------------------------------------- nb_gr = klon / kdlon IF (nb_gr*kdlon .NE. klon) THEN PRINT*, "kdlon mauvais:", klon, kdlon, nb_gr CALL abort ENDIF IF (kflev .NE. klev) THEN PRINT*, "kflev differe de klev, kflev, klev" CALL abort ENDIF c------------------------------------------- DO k = 1, klev DO i = 1, klon heat(i,k)=0. cool(i,k)=0. heat0(i,k)=0. cool0(i,k)=0. ENDDO ENDDO c zdist = dist c RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97 RCH4 = 1.72E-06* 16.043/28.97 RN2O = 310.E-09* 44.013/28.97 RCFC11 = 280.E-12* 137.3686/28.97 RCFC12 = 484.E-12* 120.9140/28.97 PSCT = solaire/zdist/zdist c DO 99999 j = 1, nb_gr iof = kdlon*(j-1) c DO i = 1, kdlon zfract(i) = fract(iof+i) zrmu0(i) = rmu0(iof+i) PALBD(i,1) = albedo(iof+i) PALBD(i,2) = albedo(iof+i) PALBP(i,1) = albedo(iof+i) PALBP(i,2) = albedo(iof+i) ccc SB jul99 PEMIS(i) = 0.96 PEMIS(i) = 0.999 PVIEW(i) = 1.66 PPSOL(i) = paprs(iof+i,1) zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2)) . / (pplay(iof+i,1)-pplay(iof+i,2)) zx_alpha2 = 1.0 - zx_alpha1 PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2 PTL(i,klev+1) = t(iof+i,klev) PDT0(i) = tsol(iof+i) - PTL(i,1) ENDDO DO k = 2, kflev DO i = 1, kdlon PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5 ENDDO ENDDO DO k = 1, kflev DO i = 1, kdlon PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1) PTAVE(i,k) = t(iof+i,k) PWV(i,k) = MAX (q(iof+i,k), 1.0e-12) PQS(i,k) = PWV(i,k) c wo: cm.atm (epaisseur en cm dans la situation standard) c POZON: kg/kg c! sb POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968 c! sb . /(paprs(iof+i,k)-paprs(iof+i,k+1)) c! sb . *(paprs(iof+i,1)/101325.0) POZON(i,k) = wo(iof+i,k) PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k) PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k) PCLDSW(i,k) = cldfra(iof+i,k) PTAU(i,1,k) = MAX(cldtau(iof+i,k), 1.0e-05)! 1e-12 serait instable PTAU(i,2,k) = MAX(cldtau(iof+i,k), 1.0e-05)! pour 32-bit machines POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k)) POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k)) PCG(i,1,k) = 0.865 PCG(i,2,k) = 0.910 ENDDO ENDDO c DO k = 1, kflev+1 DO i = 1, kdlon PPMB(i,k) = paprs(iof+i,k)/100.0 ENDDO ENDDO c DO kk = 1, 5 DO k = 1, kflev DO i = 1, kdlon PAER(i,k,kk) = 1.0E-15 ENDDO ENDDO ENDDO c c====================================================================== CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, . PPMB, PDP, . PPSOL,PDT0,PEMIS, . PTL, PTAVE, PWV, POZON, PAER, . PCLDLD,PCLDLU, . PVIEW, . zcool, zcool0, . ztoplw,zsollw,ztoplw0,zsollw0) CALL SW(PSCT, RCO2, zrmu0, zfract, S PPMB, PDP, S PPSOL, PALBD, PALBP, S PTAVE, PWV, PQS, POZON, PAER, S PCLDSW, PTAU, POMEGA, PCG, S zheat, zheat0, S zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0) c====================================================================== DO i = 1, kdlon radsol(iof+i) = zsolsw(i) + zsollw(i) topsw(iof+i) = ztopsw(i) toplw(iof+i) = ztoplw(i) solsw(iof+i) = zsolsw(i) sollw(iof+i) = zsollw(i) topsw0(iof+i) = ztopsw0(i) toplw0(iof+i) = ztoplw0(i) solsw0(iof+i) = zsolsw0(i) sollw0(iof+i) = zsollw0(i) albpla(iof+i) = zalbpla(i) ENDDO DO k = 1, kflev DO i = 1, kdlon heat(iof+i,k) = zheat(i,k) cool(iof+i,k) = zcool(i,k) heat0(iof+i,k) = zheat0(i,k) cool0(iof+i,k) = zcool0(i,k) ENDDO ENDDO c 99999 CONTINUE RETURN END SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, S PPMB, PDP, S PPSOL, PALBD, PALBP, S PTAVE, PWV, PQS, POZON, PAER, S PCLDSW, PTAU, POMEGA, PCG, S PHEAT, PHEAT0, S PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "YOMCST.h" C C ------------------------------------------------------------------ C C PURPOSE. C -------- C C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). C C METHOD. C ------- C C 1. COMPUTES ABSORBER AMOUNTS (SWU) C 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) C 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo C ------------------------------------------------------------------ C C* ARGUMENTS: C REAL*8 PSCT ! constante solaire (valeur conseillee: 1370) REAL*8 RCO2 ! concentration CO2 (IPCC: 353.E-06*44.011/28.97) C REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (PA) REAL*8 PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA) REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) C REAL*8 PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE REAL*8 PFRAC(KDLON) ! fraction de la journee C REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG) REAL*8 PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG) REAL*8 POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG) REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS C REAL*8 PALBD(KDLON,2) ! albedo du sol (lumiere diffuse) REAL*8 PALBP(KDLON,2) ! albedo du sol (lumiere parallele) C REAL*8 PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION REAL*8 PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS REAL*8 PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR REAL*8 POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO C REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY) REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky REAL*8 PALBPLA(KDLON) ! PLANETARY ALBEDO REAL*8 PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A. REAL*8 PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE REAL*8 PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) REAL*8 PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) C C* LOCAL VARIABLES: C REAL*8 ZOZ(KDLON,KFLEV) REAL*8 ZAKI(KDLON,2) REAL*8 ZCLD(KDLON,KFLEV) REAL*8 ZCLEAR(KDLON) REAL*8 ZDSIG(KDLON,KFLEV) REAL*8 ZFACT(KDLON) REAL*8 ZFD(KDLON,KFLEV+1) REAL*8 ZFDOWN(KDLON,KFLEV+1) REAL*8 ZFU(KDLON,KFLEV+1) REAL*8 ZFUP(KDLON,KFLEV+1) REAL*8 ZRMU(KDLON) REAL*8 ZSEC(KDLON) REAL*8 ZUD(KDLON,5,KFLEV+1) REAL*8 ZCLDSW0(KDLON,KFLEV) c REAL*8 ZFSUP(KDLON,KFLEV+1) REAL*8 ZFSDN(KDLON,KFLEV+1) REAL*8 ZFSUP0(KDLON,KFLEV+1) REAL*8 ZFSDN0(KDLON,KFLEV+1) SAVE ZFSUP, ZFSDN, ZFSUP0, ZFSDN0 C INTEGER inu, jl, jk, i, k, kpl1 c INTEGER swpas ! Every swpas steps, sw is calculated PARAMETER(swpas=1) c INTEGER itapsw LOGICAL appel1er DATA itapsw /0/ DATA appel1er /.TRUE./ c IF (appel1er) THEN PRINT*, 'SW calling frequency : ', swpas PRINT*, " In general, it should be 1" appel1er = .FALSE. ENDIF C ------------------------------------------------------------------ IF (MOD(itapsw,swpas).EQ.0) THEN c DO JK = 1 , KFLEV DO JL = 1, KDLON ZCLDSW0(JL,JK) = 0.0 ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG . *PDP(JL,JK)*(101325.0/PPSOL(JL)) ENDDO ENDDO C C c clear-sky: CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL, S PRMU0,PFRAC,PTAVE,PWV, S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) INU = 1 CALL SW1S(INU, S PAER, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, S ZFD, ZFU) INU = 2 CALL SW2S(INU, S PAER, ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, S PWV, PQS, S ZFDOWN, ZFUP) DO JK = 1 , KFLEV+1 DO JL = 1, KDLON ZFSUP0(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) ENDDO ENDDO c cloudy-sky: CALL SWU(PSCT,RCO2,PCLDSW,PPMB,PPSOL, S PRMU0,PFRAC,PTAVE,PWV, S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) INU = 1 CALL SW1S(INU, S PAER, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, S ZFD, ZFU) INU = 2 CALL SW2S(INU, S PAER, ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, S PWV, PQS, S ZFDOWN, ZFUP) DO JK = 1 , KFLEV+1 DO JL = 1, KDLON ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) ENDDO ENDDO c itapsw = 0 ENDIF itapsw = itapsw + 1 C DO k = 1, KFLEV kpl1 = k+1 DO i = 1, KDLON PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k)) . -(ZFSDN(i,k)-ZFSDN(i,kpl1)) PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k) PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k)) . -(ZFSDN0(i,k)-ZFSDN0(i,kpl1)) PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k) ENDDO ENDDO DO i = 1, KDLON PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20) c PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1) PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1) c PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1) PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1) ENDDO C RETURN END c SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT, S PRMU,PSEC,PUD) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "radepsi.h" include "radopt.h" include "YOMCST.h" C C* ARGUMENTS: C REAL*8 PSCT REAL*8 RCO2 REAL*8 PCLDSW(KDLON,KFLEV) REAL*8 PPMB(KDLON,KFLEV+1) REAL*8 PPSOL(KDLON) REAL*8 PRMU0(KDLON) REAL*8 PFRAC(KDLON) REAL*8 PTAVE(KDLON,KFLEV) REAL*8 PWV(KDLON,KFLEV) C REAL*8 PAKI(KDLON,2) REAL*8 PCLD(KDLON,KFLEV) REAL*8 PCLEAR(KDLON) REAL*8 PDSIG(KDLON,KFLEV) REAL*8 PFACT(KDLON) REAL*8 PRMU(KDLON) REAL*8 PSEC(KDLON) REAL*8 PUD(KDLON,5,KFLEV+1) C C* LOCAL VARIABLES: C INTEGER IIND(2) REAL*8 ZC1J(KDLON,KFLEV+1) REAL*8 ZCLEAR(KDLON) REAL*8 ZCLOUD(KDLON) REAL*8 ZN175(KDLON) REAL*8 ZN190(KDLON) REAL*8 ZO175(KDLON) REAL*8 ZO190(KDLON) REAL*8 ZSIGN(KDLON) REAL*8 ZR(KDLON,2) REAL*8 ZSIGO(KDLON) REAL*8 ZUD(KDLON,2) REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW INTEGER jl, jk, jkp1, jkl, jklp1, ja C C* Prescribed Data: c REAL*8 ZPDH2O,ZPDUMG SAVE ZPDH2O,ZPDUMG REAL*8 ZPRH2O,ZPRUMG SAVE ZPRH2O,ZPRUMG REAL*8 RTDH2O,RTDUMG SAVE RTDH2O,RTDUMG REAL*8 RTH2O ,RTUMG SAVE RTH2O ,RTUMG DATA ZPDH2O,ZPDUMG / 0.8 , 0.75 / DATA ZPRH2O,ZPRUMG / 30000., 30000. / DATA RTDH2O,RTDUMG / 0.40 , 0.375 / DATA RTH2O ,RTUMG / 240. , 240. / C ------------------------------------------------------------------ C C* 1. COMPUTES AMOUNTS OF ABSORBERS C ----------------------------- C 100 CONTINUE C IIND(1)=1 IIND(2)=2 C C C* 1.1 INITIALIZES QUANTITIES C ---------------------- C 110 CONTINUE C DO 111 JL = 1, KDLON PUD(JL,1,KFLEV+1)=0. PUD(JL,2,KFLEV+1)=0. PUD(JL,3,KFLEV+1)=0. PUD(JL,4,KFLEV+1)=0. PUD(JL,5,KFLEV+1)=0. PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35. PSEC(JL)=1./PRMU(JL) ZC1J(JL,KFLEV+1)=0. 111 CONTINUE C C* 1.3 AMOUNTS OF ABSORBERS C -------------------- C 130 CONTINUE C DO 131 JL= 1, KDLON ZUD(JL,1) = 0. ZUD(JL,2) = 0. ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.) ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.) ZSIGO(JL) = PPSOL(JL) ZCLEAR(JL)=1. ZCLOUD(JL)=0. 131 CONTINUE C DO 133 JK = 1 , KFLEV JKP1 = JK + 1 JKL = KFLEV+1 - JK JKLP1 = JKL+1 DO 132 JL = 1, KDLON ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ ) ZSIGN(JL) = 100. * PPMB(JL,JKP1) PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL) ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.) ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.) ZDSCO2 = ZO175(JL) - ZN175(JL) ZDSH2O = ZO190(JL) - ZN190(JL) PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O) . * ZDSH2O * ZWH2O * ZRTH PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG) . * ZDSCO2 * RCO2 * ZRTU ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O) PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW) ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK) ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK) ZSIGO(JL) = ZSIGN(JL) ZO175(JL) = ZN175(JL) ZO190(JL) = ZN190(JL) C IF (NOVLP.EQ.1) THEN ZCLEAR(JL)=ZCLEAR(JL) S *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL))) S /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC)) ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL) ZCLOUD(JL) = PCLDSW(JL,JKL) ELSE IF (NOVLP.EQ.2) THEN ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL)) ZC1J(JL,JKL) = ZCLOUD(JL) ELSE IF (NOVLP.EQ.3) THEN ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL)) ZCLOUD(JL) = 1.0 - ZCLEAR(JL) ZC1J(JL,JKL) = ZCLOUD(JL) END IF 132 CONTINUE 133 CONTINUE DO 134 JL=1, KDLON PCLEAR(JL)=1.-ZC1J(JL,1) 134 CONTINUE DO 136 JK=1,KFLEV DO 135 JL=1, KDLON IF (PCLEAR(JL).LT.1.) THEN PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL)) ELSE PCLD(JL,JK)=0. END IF 135 CONTINUE 136 CONTINUE C C C* 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS C ----------------------------------------------- C 140 CONTINUE C DO 142 JA = 1,2 DO 141 JL = 1, KDLON ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL) 141 CONTINUE 142 CONTINUE C CALL SWTT1(2, 2, IIND, ZUD, ZR) C DO 144 JA = 1,2 DO 143 JL = 1, KDLON PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA) 143 CONTINUE 144 CONTINUE C C C ------------------------------------------------------------------ C RETURN END SUBROUTINE SW1S ( KNU S , PAER , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD S , PFD , PFU) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" C C ------------------------------------------------------------------ C PURPOSE. C -------- C C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). C C METHOD. C ------- C C 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO C CONTINUUM SCATTERING C 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO C ------------------------------------------------------------------ C C* ARGUMENTS: C INTEGER KNU REAL*8 PAER(KDLON,KFLEV,5) REAL*8 PALBD(KDLON,2) REAL*8 PALBP(KDLON,2) REAL*8 PCG(KDLON,2,KFLEV) REAL*8 PCLD(KDLON,KFLEV) REAL*8 PCLDSW(KDLON,KFLEV) REAL*8 PCLEAR(KDLON) REAL*8 PDSIG(KDLON,KFLEV) REAL*8 POMEGA(KDLON,2,KFLEV) REAL*8 POZ(KDLON,KFLEV) REAL*8 PRMU(KDLON) REAL*8 PSEC(KDLON) REAL*8 PTAU(KDLON,2,KFLEV) REAL*8 PUD(KDLON,5,KFLEV+1) C REAL*8 PFD(KDLON,KFLEV+1) REAL*8 PFU(KDLON,KFLEV+1) C C* LOCAL VARIABLES: C INTEGER IIND(4) C REAL*8 ZCGAZ(KDLON,KFLEV) REAL*8 ZDIFF(KDLON) REAL*8 ZDIRF(KDLON) REAL*8 ZPIZAZ(KDLON,KFLEV) REAL*8 ZRAYL(KDLON) REAL*8 ZRAY1(KDLON,KFLEV+1) REAL*8 ZRAY2(KDLON,KFLEV+1) REAL*8 ZREFZ(KDLON,2,KFLEV+1) REAL*8 ZRJ(KDLON,6,KFLEV+1) REAL*8 ZRJ0(KDLON,6,KFLEV+1) REAL*8 ZRK(KDLON,6,KFLEV+1) REAL*8 ZRK0(KDLON,6,KFLEV+1) REAL*8 ZRMUE(KDLON,KFLEV+1) REAL*8 ZRMU0(KDLON,KFLEV+1) REAL*8 ZR(KDLON,4) REAL*8 ZTAUAZ(KDLON,KFLEV) REAL*8 ZTRA1(KDLON,KFLEV+1) REAL*8 ZTRA2(KDLON,KFLEV+1) REAL*8 ZW(KDLON,4) C INTEGER jl, jk, k, jaj, ikm1, ikl c c Prescribed Data: c REAL*8 RSUN(2) SAVE RSUN REAL*8 RRAY(2,6) SAVE RRAY DATA RSUN(1) / 0.441676 / DATA RSUN(2) / 0.558324 / DATA (RRAY(1,K),K=1,6) / S .428937E-01, .890743E+00,-.288555E+01, S .522744E+01,-.469173E+01, .161645E+01/ DATA (RRAY(2,K),K=1,6) / S .697200E-02, .173297E-01,-.850903E-01, S .248261E+00,-.302031E+00, .129662E+00/ C ------------------------------------------------------------------ C C* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON) C ----------------------- ------------------ C 100 CONTINUE C C C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING C ----------------------------------------- C 110 CONTINUE C DO 111 JL = 1, KDLON ZRAYL(JL) = RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL) S * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL) S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) )))) 111 CONTINUE C C C ------------------------------------------------------------------ C C* 2. CONTINUUM SCATTERING CALCULATIONS C --------------------------------- C 200 CONTINUE C C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN C -------------------------------- C 210 CONTINUE C CALL SWCLR ( KNU S , PAER , PALBP , PDSIG , ZRAYL, PSEC S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) C C C* 2.2 CLOUDY FRACTION OF THE COLUMN C ----------------------------- C 220 CONTINUE C CALL SWR ( KNU S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL S , PSEC ,PTAU S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE S , ZTAUAZ,ZTRA1 ,ZTRA2) C C C ------------------------------------------------------------------ C C* 3. OZONE ABSORPTION C ---------------- C 300 CONTINUE C IIND(1)=1 IIND(2)=3 IIND(3)=1 IIND(4)=3 C C C* 3.1 DOWNWARD FLUXES C --------------- C 310 CONTINUE C JAJ = 2 C DO 311 JL = 1, KDLON ZW(JL,1)=0. ZW(JL,2)=0. ZW(JL,3)=0. ZW(JL,4)=0. PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1) S + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU) 311 CONTINUE DO 314 JK = 1 , KFLEV IKL = KFLEV+1-JK DO 312 JL = 1, KDLON ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL) ZW(JL,2)=ZW(JL,2)+POZ(JL, IKL)/ZRMUE(JL,IKL) ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) ZW(JL,4)=ZW(JL,4)+POZ(JL, IKL)/ZRMU0(JL,IKL) 312 CONTINUE C CALL SWTT1(KNU, 4, IIND, ZW, ZR) C DO 313 JL = 1, KDLON ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL) ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL) PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL) S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) 313 CONTINUE 314 CONTINUE C C C* 3.2 UPWARD FLUXES C ------------- C 320 CONTINUE C DO 325 JL = 1, KDLON PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU) S + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU)) S * RSUN(KNU) 325 CONTINUE C DO 328 JK = 2 , KFLEV+1 IKM1=JK-1 DO 326 JL = 1, KDLON ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66 ZW(JL,2)=ZW(JL,2)+POZ(JL, IKM1)*1.66 ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66 ZW(JL,4)=ZW(JL,4)+POZ(JL, IKM1)*1.66 326 CONTINUE C CALL SWTT1(KNU, 4, IIND, ZW, ZR) C DO 327 JL = 1, KDLON ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK) ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK) PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL) S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) 327 CONTINUE 328 CONTINUE C C ------------------------------------------------------------------ C RETURN END SUBROUTINE SW2S ( KNU S , PAER ,PAKI, PALBD, PALBP, PCG , PCLD, PCLEAR, PCLDSW S , PDSIG ,POMEGA,POZ , PRMU , PSEC , PTAU S , PUD ,PWV , PQS S , PFDOWN,PFUP ) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "radepsi.h" C C ------------------------------------------------------------------ C PURPOSE. C -------- C C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE C SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980). C C METHOD. C ------- C C 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO C CONTINUUM SCATTERING C 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR C A GREY MOLECULAR ABSORPTION C 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS C OF ABSORBERS C 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS C 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO C ------------------------------------------------------------------ C* ARGUMENTS: C INTEGER KNU REAL*8 PAER(KDLON,KFLEV,5) REAL*8 PAKI(KDLON,2) REAL*8 PALBD(KDLON,2) REAL*8 PALBP(KDLON,2) REAL*8 PCG(KDLON,2,KFLEV) REAL*8 PCLD(KDLON,KFLEV) REAL*8 PCLDSW(KDLON,KFLEV) REAL*8 PCLEAR(KDLON) REAL*8 PDSIG(KDLON,KFLEV) REAL*8 POMEGA(KDLON,2,KFLEV) REAL*8 POZ(KDLON,KFLEV) REAL*8 PQS(KDLON,KFLEV) REAL*8 PRMU(KDLON) REAL*8 PSEC(KDLON) REAL*8 PTAU(KDLON,2,KFLEV) REAL*8 PUD(KDLON,5,KFLEV+1) REAL*8 PWV(KDLON,KFLEV) C REAL*8 PFDOWN(KDLON,KFLEV+1) REAL*8 PFUP(KDLON,KFLEV+1) C C* LOCAL VARIABLES: C INTEGER IIND2(2), IIND3(3) REAL*8 ZCGAZ(KDLON,KFLEV) REAL*8 ZFD(KDLON,KFLEV+1) REAL*8 ZFU(KDLON,KFLEV+1) REAL*8 ZG(KDLON) REAL*8 ZGG(KDLON) REAL*8 ZPIZAZ(KDLON,KFLEV) REAL*8 ZRAYL(KDLON) REAL*8 ZRAY1(KDLON,KFLEV+1) REAL*8 ZRAY2(KDLON,KFLEV+1) REAL*8 ZREF(KDLON) REAL*8 ZREFZ(KDLON,2,KFLEV+1) REAL*8 ZRE1(KDLON) REAL*8 ZRE2(KDLON) REAL*8 ZRJ(KDLON,6,KFLEV+1) REAL*8 ZRJ0(KDLON,6,KFLEV+1) REAL*8 ZRK(KDLON,6,KFLEV+1) REAL*8 ZRK0(KDLON,6,KFLEV+1) REAL*8 ZRL(KDLON,8) REAL*8 ZRMUE(KDLON,KFLEV+1) REAL*8 ZRMU0(KDLON,KFLEV+1) REAL*8 ZRMUZ(KDLON) REAL*8 ZRNEB(KDLON) REAL*8 ZRUEF(KDLON,8) REAL*8 ZR1(KDLON) REAL*8 ZR2(KDLON,2) REAL*8 ZR3(KDLON,3) REAL*8 ZR4(KDLON) REAL*8 ZR21(KDLON) REAL*8 ZR22(KDLON) REAL*8 ZS(KDLON) REAL*8 ZTAUAZ(KDLON,KFLEV) REAL*8 ZTO1(KDLON) REAL*8 ZTR(KDLON,2,KFLEV+1) REAL*8 ZTRA1(KDLON,KFLEV+1) REAL*8 ZTRA2(KDLON,KFLEV+1) REAL*8 ZTR1(KDLON) REAL*8 ZTR2(KDLON) REAL*8 ZW(KDLON) REAL*8 ZW1(KDLON) REAL*8 ZW2(KDLON,2) REAL*8 ZW3(KDLON,3) REAL*8 ZW4(KDLON) REAL*8 ZW5(KDLON) C INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11 C C* Prescribed Data: C REAL*8 RSUN(2) SAVE RSUN REAL*8 RRAY(2,6) SAVE RRAY DATA RSUN(1) / 0.441676 / DATA RSUN(2) / 0.558324 / DATA (RRAY(1,K),K=1,6) / S .428937E-01, .890743E+00,-.288555E+01, S .522744E+01,-.469173E+01, .161645E+01/ DATA (RRAY(2,K),K=1,6) / S .697200E-02, .173297E-01,-.850903E-01, S .248261E+00,-.302031E+00, .129662E+00/ C C ------------------------------------------------------------------ C C* 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON) C ------------------------------------------- C 100 CONTINUE C C C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING C ----------------------------------------- C 110 CONTINUE C DO 111 JL = 1, KDLON ZRMUM1 = 1. - PRMU(JL) ZRAYL(JL) = RRAY(KNU,1) + ZRMUM1 * (RRAY(KNU,2) + ZRMUM1 S * (RRAY(KNU,3) + ZRMUM1 * (RRAY(KNU,4) + ZRMUM1 S * (RRAY(KNU,5) + ZRMUM1 * RRAY(KNU,6) )))) 111 CONTINUE C C C ------------------------------------------------------------------ C C* 2. CONTINUUM SCATTERING CALCULATIONS C --------------------------------- C 200 CONTINUE C C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN C -------------------------------- C 210 CONTINUE C CALL SWCLR ( KNU S , PAER , PALBP , PDSIG , ZRAYL, PSEC S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) C C C* 2.2 CLOUDY FRACTION OF THE COLUMN C ----------------------------- C 220 CONTINUE C CALL SWR ( KNU S , PALBD , PCG , PCLD , PDSIG, POMEGA, ZRAYL S , PSEC , PTAU S , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ , ZRK, ZRMUE S , ZTAUAZ, ZTRA1 , ZTRA2) C C C ------------------------------------------------------------------ C C* 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION C ------------------------------------------------------ C 300 CONTINUE C JN = 2 C DO 361 JABS=1,2 C C C* 3.1 SURFACE CONDITIONS C ------------------ C 310 CONTINUE C DO 311 JL = 1, KDLON ZREFZ(JL,2,1) = PALBD(JL,KNU) ZREFZ(JL,1,1) = PALBD(JL,KNU) 311 CONTINUE C C C* 3.2 INTRODUCING CLOUD EFFECTS C ------------------------- C 320 CONTINUE C DO 324 JK = 2 , KFLEV+1 JKM1 = JK - 1 IKL=KFLEV+1-JKM1 DO 322 JL = 1, KDLON ZRNEB(JL) = PCLD(JL,JKM1) IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN ZWH2O=MAX(PWV(JL,JKM1),ZEELOG) ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG)) ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG) ELSE ZAA=PUD(JL,JABS,JKM1) ZBB=ZAA END IF ZRKI = PAKI(JL,JABS) ZS(JL) = EXP(-ZRKI * ZAA * 1.66) ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK)) ZTR1(JL) = 0. ZRE1(JL) = 0. ZTR2(JL) = 0. ZRE2(JL) = 0. C ZW(JL)= POMEGA(JL,KNU,JKM1) ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL) S + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1) S + ZBB * ZRKI ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1) ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) S + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1) ZW(JL) = ZR21(JL) / ZTO1(JL) ZREF(JL) = ZREFZ(JL,1,JKM1) ZRMUZ(JL) = ZRMUE(JL,JK) 322 CONTINUE C CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW, S ZRE1, ZRE2, ZTR1, ZTR2) C DO 323 JL = 1, KDLON C ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1) S + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1) S * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL) S + ZRNEB(JL) * ZRE1(JL) C ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL) S + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL)) C ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1) S +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1) S /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL) S + ZRNEB(JL) * ZRE2(JL) C ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL) S + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1) S * ZREFZ(JL,1,JKM1))) S * ZG(JL) * (1. -ZRNEB(JL)) C 323 CONTINUE 324 CONTINUE C C* 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL C ------------------------------------------------- C 330 CONTINUE C DO 351 JREF=1,2 C JN = JN + 1 C DO 331 JL = 1, KDLON ZRJ(JL,JN,KFLEV+1) = 1. ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1) 331 CONTINUE C DO 333 JK = 1 , KFLEV JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 332 JL = 1, KDLON ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL) ZRJ(JL,JN,JKL) = ZRE11 ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL) 332 CONTINUE 333 CONTINUE 351 CONTINUE 361 CONTINUE C C C ------------------------------------------------------------------ C C* 4. INVERT GREY AND CONTINUUM FLUXES C -------------------------------- C 400 CONTINUE C C C* 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES C --------------------------------------------- C 410 CONTINUE C DO 414 JK = 1 , KFLEV+1 DO 413 JAJ = 1 , 5 , 2 JAJP = JAJ + 1 DO 412 JL = 1, KDLON ZRJ(JL,JAJ,JK)= ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK) ZRK(JL,JAJ,JK)= ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK) ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) 412 CONTINUE 413 CONTINUE 414 CONTINUE C DO 417 JK = 1 , KFLEV+1 DO 416 JAJ = 2 , 6 , 2 DO 415 JL = 1, KDLON ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) 415 CONTINUE 416 CONTINUE 417 CONTINUE C C* 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE C --------------------------------------------- C 420 CONTINUE C DO 437 JK = 1 , KFLEV+1 JKKI = 1 DO 425 JAJ = 1 , 2 IIND2(1)=JAJ IIND2(2)=JAJ DO 424 JN = 1 , 2 JN2J = JN + 2 * JAJ JKKP4 = JKKI + 4 C C* 4.2.1 EFFECTIVE ABSORBER AMOUNTS C -------------------------- C 4210 CONTINUE C DO 4211 JL = 1, KDLON ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK)) S / PAKI(JL,JAJ) ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK)) S / PAKI(JL,JAJ) 4211 CONTINUE C C* 4.2.2 TRANSMISSION FUNCTION C --------------------- C 4220 CONTINUE C CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2) C DO 4221 JL = 1, KDLON ZRL(JL,JKKI) = ZR2(JL,1) ZRUEF(JL,JKKI) = ZW2(JL,1) ZRL(JL,JKKP4) = ZR2(JL,2) ZRUEF(JL,JKKP4) = ZW2(JL,2) 4221 CONTINUE C JKKI=JKKI+1 424 CONTINUE 425 CONTINUE C C* 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION C ------------------------------------------------------ C 430 CONTINUE C DO 431 JL = 1, KDLON PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3) S + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4) PFUP(JL,JK) = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7) S + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8) 431 CONTINUE 437 CONTINUE C C C ------------------------------------------------------------------ C C* 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES C ---------------------------------------- C 500 CONTINUE C C C* 5.1 DOWNWARD FLUXES C --------------- C 510 CONTINUE C JAJ = 2 IIND3(1)=1 IIND3(2)=2 IIND3(3)=3 C DO 511 JL = 1, KDLON ZW3(JL,1)=0. ZW3(JL,2)=0. ZW3(JL,3)=0. ZW4(JL) =0. ZW5(JL) =0. ZR4(JL) =1. ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1) 511 CONTINUE DO 514 JK = 1 , KFLEV IKL = KFLEV+1-JK DO 512 JL = 1, KDLON ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL) ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKL)/ZRMU0(JL,IKL) ZW4(JL) =ZW4(JL) +PUD(JL,4,IKL)/ZRMU0(JL,IKL) ZW5(JL) =ZW5(JL) +PUD(JL,5,IKL)/ZRMU0(JL,IKL) 512 CONTINUE C CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3) C DO 513 JL = 1, KDLON C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) S * ZRJ0(JL,JAJ,IKL) 513 CONTINUE 514 CONTINUE C C C* 5.2 UPWARD FLUXES C ------------- C 520 CONTINUE C DO 525 JL = 1, KDLON ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU) 525 CONTINUE C DO 528 JK = 2 , KFLEV+1 IKM1=JK-1 DO 526 JL = 1, KDLON ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66 ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66 ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKM1)*1.66 ZW4(JL) =ZW4(JL) +PUD(JL,4,IKM1)*1.66 ZW5(JL) =ZW5(JL) +PUD(JL,5,IKM1)*1.66 526 CONTINUE C CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3) C DO 527 JL = 1, KDLON C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) S * ZRK0(JL,JAJ,JK) 527 CONTINUE 528 CONTINUE C C C ------------------------------------------------------------------ C C* 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION C -------------------------------------------------- C 600 CONTINUE IABS=3 C C* 6.1 DOWNWARD FLUXES C --------------- C 610 CONTINUE DO 611 JL = 1, KDLON ZW1(JL)=0. ZW4(JL)=0. ZW5(JL)=0. ZR1(JL)=0. PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1) S + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU) 611 CONTINUE C DO 614 JK = 1 , KFLEV IKL=KFLEV+1-JK DO 612 JL = 1, KDLON ZW1(JL) = ZW1(JL)+POZ(JL, IKL)/ZRMUE(JL,IKL) ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL) ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL) C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 612 CONTINUE C CALL SWTT(KNU, IABS, ZW1, ZR1) C DO 613 JL = 1, KDLON PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL) S +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU) 613 CONTINUE 614 CONTINUE C C C* 6.2 UPWARD FLUXES C ------------- C 620 CONTINUE DO 621 JL = 1, KDLON PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1) S +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU) 621 CONTINUE C DO 624 JK = 2 , KFLEV+1 IKM1=JK-1 DO 622 JL = 1, KDLON ZW1(JL) = ZW1(JL)+POZ(JL ,IKM1)*1.66 ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66 ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 622 CONTINUE C CALL SWTT(KNU, IABS, ZW1, ZR1) C DO 623 JL = 1, KDLON PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK) S +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU) 623 CONTINUE 624 CONTINUE C C ------------------------------------------------------------------ C RETURN END SUBROUTINE SWCLR ( KNU S , PAER , PALBP , PDSIG , PRAYL , PSEC S , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ S , PRK , PRMU0 , PTAUAZ, PTRA1 , PTRA2 ) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "radepsi.h" include "radopt.h" C C ------------------------------------------------------------------ C PURPOSE. C -------- C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF C CLEAR-SKY COLUMN C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 94-11-15 C ------------------------------------------------------------------ C* ARGUMENTS: C INTEGER KNU REAL*8 PAER(KDLON,KFLEV,5) REAL*8 PALBP(KDLON,2) REAL*8 PDSIG(KDLON,KFLEV) REAL*8 PRAYL(KDLON) REAL*8 PSEC(KDLON) C REAL*8 PCGAZ(KDLON,KFLEV) REAL*8 PPIZAZ(KDLON,KFLEV) REAL*8 PRAY1(KDLON,KFLEV+1) REAL*8 PRAY2(KDLON,KFLEV+1) REAL*8 PREFZ(KDLON,2,KFLEV+1) REAL*8 PRJ(KDLON,6,KFLEV+1) REAL*8 PRK(KDLON,6,KFLEV+1) REAL*8 PRMU0(KDLON,KFLEV+1) REAL*8 PTAUAZ(KDLON,KFLEV) REAL*8 PTRA1(KDLON,KFLEV+1) REAL*8 PTRA2(KDLON,KFLEV+1) C C* LOCAL VARIABLES: C REAL*8 ZC0I(KDLON,KFLEV+1) REAL*8 ZCLE0(KDLON,KFLEV) REAL*8 ZCLEAR(KDLON) REAL*8 ZR21(KDLON) REAL*8 ZR23(KDLON) REAL*8 ZSS0(KDLON) REAL*8 ZSCAT(KDLON) REAL*8 ZTR(KDLON,2,KFLEV+1) C INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1 REAL*8 ZBMU0, ZBMU1, ZRE11 C C* Prescribed Data for Aerosols: C REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5) SAVE TAUA, RPIZA, RCGA DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) / S .730719, .912819, .725059, .745405, .682188 , S .730719, .912819, .725059, .745405, .682188 / DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) / S .872212, .982545, .623143, .944887, .997975 , S .872212, .982545, .623143, .944887, .997975 / DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) / S .647596, .739002, .580845, .662657, .624246 , S .647596, .739002, .580845, .662657, .624246 / C ------------------------------------------------------------------ C C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH C -------------------------------------------- C 100 CONTINUE C DO 103 JK = 1 , KFLEV+1 DO 102 JA = 1 , 6 DO 101 JL = 1, KDLON PRJ(JL,JA,JK) = 0. PRK(JL,JA,JK) = 0. 101 CONTINUE 102 CONTINUE 103 CONTINUE C DO 108 JK = 1 , KFLEV DO 104 JL = 1, KDLON PCGAZ(JL,JK) = 0. PPIZAZ(JL,JK) = 0. PTAUAZ(JL,JK) = 0. 104 CONTINUE DO 106 JAE=1,5 DO 105 JL = 1, KDLON PTAUAZ(JL,JK)=PTAUAZ(JL,JK) S +PAER(JL,JK,JAE)*TAUA(KNU,JAE) PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE) S * TAUA(KNU,JAE)*RPIZA(KNU,JAE) PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE) S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE) 105 CONTINUE 106 CONTINUE C DO 107 JL = 1, KDLON IF (KAER.NE.0) THEN PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK) PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK) ZTRAY = PRAYL(JL) * PDSIG(JL,JK) ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK)) ZGAR = PCGAZ(JL,JK) ZFF = ZGAR * ZGAR PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF) PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR) PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF) S / (1. - PPIZAZ(JL,JK) * ZFF) ELSE ZTRAY = PRAYL(JL) * PDSIG(JL,JK) PTAUAZ(JL,JK) = ZTRAY PCGAZ(JL,JK) = 0. PPIZAZ(JL,JK) = 1.-REPSCT END IF 107 CONTINUE c PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5) c $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON) c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5) C 108 CONTINUE C C ------------------------------------------------------------------ C C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL C ---------------------------------------------- C 200 CONTINUE C DO 201 JL = 1, KDLON ZR23(JL) = 0. ZC0I(JL,KFLEV+1) = 0. ZCLEAR(JL) = 1. ZSCAT(JL) = 0. 201 CONTINUE C JK = 1 JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 202 JL = 1, KDLON ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) ZR21(JL) = EXP(-ZCORAE ) ZSS0(JL) = 1.-ZR21(JL) ZCLE0(JL,JKL) = ZSS0(JL) C IF (NOVLP.EQ.1) THEN c* maximum-random ZCLEAR(JL) = ZCLEAR(JL) S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) ZSCAT(JL) = ZSS0(JL) ELSE IF (NOVLP.EQ.2) THEN C* maximum ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) ZC0I(JL,JKL) = ZSCAT(JL) ELSE IF (NOVLP.EQ.3) THEN c* random ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) ZSCAT(JL) = 1.0 - ZCLEAR(JL) ZC0I(JL,JKL) = ZSCAT(JL) END IF 202 CONTINUE C DO 205 JK = 2 , KFLEV JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 204 JL = 1, KDLON ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) ZR21(JL) = EXP(-ZCORAE ) ZSS0(JL) = 1.-ZR21(JL) ZCLE0(JL,JKL) = ZSS0(JL) c IF (NOVLP.EQ.1) THEN c* maximum-random ZCLEAR(JL) = ZCLEAR(JL) S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) ZSCAT(JL) = ZSS0(JL) ELSE IF (NOVLP.EQ.2) THEN C* maximum ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) ZC0I(JL,JKL) = ZSCAT(JL) ELSE IF (NOVLP.EQ.3) THEN c* random ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) ZSCAT(JL) = 1.0 - ZCLEAR(JL) ZC0I(JL,JKL) = ZSCAT(JL) END IF 204 CONTINUE 205 CONTINUE C C ------------------------------------------------------------------ C C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING C ----------------------------------------------- C 300 CONTINUE C DO 301 JL = 1, KDLON PRAY1(JL,KFLEV+1) = 0. PRAY2(JL,KFLEV+1) = 0. PREFZ(JL,2,1) = PALBP(JL,KNU) PREFZ(JL,1,1) = PALBP(JL,KNU) PTRA1(JL,KFLEV+1) = 1. PTRA2(JL,KFLEV+1) = 1. 301 CONTINUE C DO 346 JK = 2 , KFLEV+1 JKM1 = JK-1 DO 342 JL = 1, KDLON C C C ------------------------------------------------------------------ C C* 3.1 EQUIVALENT ZENITH ANGLE C ----------------------- C 310 CONTINUE C ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL) S + ZC0I(JL,JK) * 1.66 PRMU0(JL,JK) = 1./ZMUE C C C ------------------------------------------------------------------ C C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS C ---------------------------------------------------- C 320 CONTINUE C ZGAP = PCGAZ(JL,JKM1) ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE ZWW = PPIZAZ(JL,JKM1) ZTO = PTAUAZ(JL,JKM1) ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN PTRA1(JL,JKM1) = 1. / ZDEN C ZMU1 = 0.5 ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 PTRA2(JL,JKM1) = 1. / ZDEN1 C C C PREFZ(JL,1,JK) = (PRAY1(JL,JKM1) S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) S * PTRA2(JL,JKM1) S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) C ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1) S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) C PREFZ(JL,2,JK) = (PRAY1(JL,JKM1) S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) S * PTRA2(JL,JKM1) ) C ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) C 342 CONTINUE 346 CONTINUE DO 347 JL = 1, KDLON ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66 PRMU0(JL,1)=1./ZMUE 347 CONTINUE C C C ------------------------------------------------------------------ C C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL C ------------------------------------------------- C 350 CONTINUE C IF (KNU.EQ.1) THEN JAJ = 2 DO 351 JL = 1, KDLON PRJ(JL,JAJ,KFLEV+1) = 1. PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) 351 CONTINUE C DO 353 JK = 1 , KFLEV JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 352 JL = 1, KDLON ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) PRJ(JL,JAJ,JKL) = ZRE11 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) 352 CONTINUE 353 CONTINUE 354 CONTINUE C ELSE C DO 358 JAJ = 1 , 2 DO 355 JL = 1, KDLON PRJ(JL,JAJ,KFLEV+1) = 1. PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) 355 CONTINUE C DO 357 JK = 1 , KFLEV JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 356 JL = 1, KDLON ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) PRJ(JL,JAJ,JKL) = ZRE11 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) 356 CONTINUE 357 CONTINUE 358 CONTINUE C END IF C C ------------------------------------------------------------------ C RETURN END SUBROUTINE SWR ( KNU S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL S , PSEC , PTAU S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE S , PTAUAZ, PTRA1 , PTRA2 ) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "radepsi.h" include "radopt.h" C C ------------------------------------------------------------------ C PURPOSE. C -------- C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF C CONTINUUM SCATTERING C C METHOD. C ------- C C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION) C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C ------------------------------------------------------------------ C* ARGUMENTS: C INTEGER KNU REAL*8 PALBD(KDLON,2) REAL*8 PCG(KDLON,2,KFLEV) REAL*8 PCLD(KDLON,KFLEV) REAL*8 PDSIG(KDLON,KFLEV) REAL*8 POMEGA(KDLON,2,KFLEV) REAL*8 PRAYL(KDLON) REAL*8 PSEC(KDLON) REAL*8 PTAU(KDLON,2,KFLEV) C REAL*8 PRAY1(KDLON,KFLEV+1) REAL*8 PRAY2(KDLON,KFLEV+1) REAL*8 PREFZ(KDLON,2,KFLEV+1) REAL*8 PRJ(KDLON,6,KFLEV+1) REAL*8 PRK(KDLON,6,KFLEV+1) REAL*8 PRMUE(KDLON,KFLEV+1) REAL*8 PCGAZ(KDLON,KFLEV) REAL*8 PPIZAZ(KDLON,KFLEV) REAL*8 PTAUAZ(KDLON,KFLEV) REAL*8 PTRA1(KDLON,KFLEV+1) REAL*8 PTRA2(KDLON,KFLEV+1) C C* LOCAL VARIABLES: C REAL*8 ZC1I(KDLON,KFLEV+1) REAL*8 ZCLEQ(KDLON,KFLEV) REAL*8 ZCLEAR(KDLON) REAL*8 ZCLOUD(KDLON) REAL*8 ZGG(KDLON) REAL*8 ZREF(KDLON) REAL*8 ZRE1(KDLON) REAL*8 ZRE2(KDLON) REAL*8 ZRMUZ(KDLON) REAL*8 ZRNEB(KDLON) REAL*8 ZR21(KDLON) REAL*8 ZR22(KDLON) REAL*8 ZR23(KDLON) REAL*8 ZSS1(KDLON) REAL*8 ZTO1(KDLON) REAL*8 ZTR(KDLON,2,KFLEV+1) REAL*8 ZTR1(KDLON) REAL*8 ZTR2(KDLON) REAL*8 ZW(KDLON) C INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1 REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1 C C ------------------------------------------------------------------ C C* 1. INITIALIZATION C -------------- C 100 CONTINUE C DO 103 JK = 1 , KFLEV+1 DO 102 JA = 1 , 6 DO 101 JL = 1, KDLON PRJ(JL,JA,JK) = 0. PRK(JL,JA,JK) = 0. 101 CONTINUE 102 CONTINUE 103 CONTINUE C C C ------------------------------------------------------------------ C C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL C ---------------------------------------------- C 200 CONTINUE C DO 201 JL = 1, KDLON ZR23(JL) = 0. ZC1I(JL,KFLEV+1) = 0. ZCLEAR(JL) = 1. ZCLOUD(JL) = 0. 201 CONTINUE C JK = 1 JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 202 JL = 1, KDLON ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) S * PCG(JL,KNU,JKL) ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) ZR21(JL) = EXP(-ZCORAE ) ZR22(JL) = EXP(-ZCORCD ) ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) ZCLEQ(JL,JKL) = ZSS1(JL) C IF (NOVLP.EQ.1) THEN c* maximum-random ZCLEAR(JL) = ZCLEAR(JL) S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) ZCLOUD(JL) = ZSS1(JL) ELSE IF (NOVLP.EQ.2) THEN C* maximum ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) ZC1I(JL,JKL) = ZCLOUD(JL) ELSE IF (NOVLP.EQ.3) THEN c* random ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) ZCLOUD(JL) = 1.0 - ZCLEAR(JL) ZC1I(JL,JKL) = ZCLOUD(JL) END IF 202 CONTINUE C DO 205 JK = 2 , KFLEV JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 204 JL = 1, KDLON ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) S * PCG(JL,KNU,JKL) ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) ZR21(JL) = EXP(-ZCORAE ) ZR22(JL) = EXP(-ZCORCD ) ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) ZCLEQ(JL,JKL) = ZSS1(JL) c IF (NOVLP.EQ.1) THEN c* maximum-random ZCLEAR(JL) = ZCLEAR(JL) S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) ZCLOUD(JL) = ZSS1(JL) ELSE IF (NOVLP.EQ.2) THEN C* maximum ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) ZC1I(JL,JKL) = ZCLOUD(JL) ELSE IF (NOVLP.EQ.3) THEN c* random ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) ZCLOUD(JL) = 1.0 - ZCLEAR(JL) ZC1I(JL,JKL) = ZCLOUD(JL) END IF 204 CONTINUE 205 CONTINUE C C ------------------------------------------------------------------ C C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING C ----------------------------------------------- C 300 CONTINUE C DO 301 JL = 1, KDLON PRAY1(JL,KFLEV+1) = 0. PRAY2(JL,KFLEV+1) = 0. PREFZ(JL,2,1) = PALBD(JL,KNU) PREFZ(JL,1,1) = PALBD(JL,KNU) PTRA1(JL,KFLEV+1) = 1. PTRA2(JL,KFLEV+1) = 1. 301 CONTINUE C DO 346 JK = 2 , KFLEV+1 JKM1 = JK-1 DO 342 JL = 1, KDLON ZRNEB(JL)= PCLD(JL,JKM1) ZRE1(JL)=0. ZTR1(JL)=0. ZRE2(JL)=0. ZTR2(JL)=0. C C C ------------------------------------------------------------------ C C* 3.1 EQUIVALENT ZENITH ANGLE C ----------------------- C 310 CONTINUE C ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL) S + ZC1I(JL,JK) * 1.66 PRMUE(JL,JK) = 1./ZMUE C C C ------------------------------------------------------------------ C C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS C ---------------------------------------------------- C 320 CONTINUE C ZGAP = PCGAZ(JL,JKM1) ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE ZWW = PPIZAZ(JL,JKM1) ZTO = PTAUAZ(JL,JKM1) ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN PTRA1(JL,JKM1) = 1. / ZDEN c PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1) C ZMU1 = 0.5 ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 PTRA2(JL,JKM1) = 1. / ZDEN1 C C C ------------------------------------------------------------------ C C* 3.3 EFFECT OF CLOUD LAYER C --------------------- C 330 CONTINUE C ZW(JL) = POMEGA(JL,KNU,JKM1) ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL) S + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1) ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1) ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) S + (1. - ZR22(JL)) * PCGAZ(JL,JKM1) C Modif PhD - JJM 19/03/96 pour erreurs arrondis C machine C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL) IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN ZW(JL)=1. ELSE ZW(JL) = ZR21(JL) / ZTO1(JL) END IF ZREF(JL) = PREFZ(JL,1,JKM1) ZRMUZ(JL) = PRMUE(JL,JK) 342 CONTINUE C CALL SWDE(ZGG , ZREF , ZRMUZ , ZTO1 , ZW, S ZRE1 , ZRE2 , ZTR1 , ZTR2) C DO 345 JL = 1, KDLON C PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) S * PTRA2(JL,JKM1) S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) S + ZRNEB(JL) * ZRE2(JL) C ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1) S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) S * (1.-ZRNEB(JL)) C PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) S * PTRA2(JL,JKM1) ) S + ZRNEB(JL) * ZRE1(JL) C ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL) S + PTRA1(JL,JKM1) * (1.-ZRNEB(JL)) C 345 CONTINUE 346 CONTINUE DO 347 JL = 1, KDLON ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66 PRMUE(JL,1)=1./ZMUE 347 CONTINUE C C C ------------------------------------------------------------------ C C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL C ------------------------------------------------- C 350 CONTINUE C IF (KNU.EQ.1) THEN JAJ = 2 DO 351 JL = 1, KDLON PRJ(JL,JAJ,KFLEV+1) = 1. PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) 351 CONTINUE C DO 353 JK = 1 , KFLEV JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 352 JL = 1, KDLON ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) PRJ(JL,JAJ,JKL) = ZRE11 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) 352 CONTINUE 353 CONTINUE 354 CONTINUE C ELSE C DO 358 JAJ = 1 , 2 DO 355 JL = 1, KDLON PRJ(JL,JAJ,KFLEV+1) = 1. PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) 355 CONTINUE C DO 357 JK = 1 , KFLEV JKL = KFLEV+1 - JK JKLP1 = JKL + 1 DO 356 JL = 1, KDLON ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) PRJ(JL,JAJ,JKL) = ZRE11 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) 356 CONTINUE 357 CONTINUE 358 CONTINUE C END IF C C ------------------------------------------------------------------ C RETURN END SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW, S PRE1,PRE2,PTR1,PTR2) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" C C ------------------------------------------------------------------ C PURPOSE. C -------- C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY C LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION. C C METHOD. C ------- C C STANDARD DELTA-EDDINGTON LAYER CALCULATIONS. C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 88-12-15 C ------------------------------------------------------------------ C* ARGUMENTS: C REAL*8 PGG(KDLON) ! ASSYMETRY FACTOR REAL*8 PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE REAL*8 PTO1(KDLON) ! OPTICAL THICKNESS REAL*8 PW(KDLON) ! SINGLE SCATTERING ALBEDO REAL*8 PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION) REAL*8 PRE2(KDLON) ! LAYER REFLECTIVITY REAL*8 PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION) REAL*8 PTR2(KDLON) ! LAYER TRANSMISSIVITY C C* LOCAL VARIABLES: C INTEGER jl REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23 REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A REAL*8 ZRI0B, ZRI1B REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D C ------------------------------------------------------------------ C C* 1. DELTA-EDDINGTON CALCULATIONS C 100 CONTINUE C DO 131 JL = 1, KDLON C C* 1.1 SET UP THE DELTA-MODIFIED PARAMETERS C 110 CONTINUE C ZFF = PGG(JL)*PGG(JL) ZGP = PGG(JL)/(1.+PGG(JL)) ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL) ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF) ZDT = 2./3. ZX1 = 1.-ZWCP*ZGP ZWM = 1.-ZWCP ZRM2 = PRMUZ(JL) * PRMUZ(JL) ZRK = SQRT(3.*ZWM*ZX1) ZX2 = 4.*(1.-ZRK*ZRK*ZRM2) ZRP=ZRK/ZX1 ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2 ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2 ZARG=MIN(ZTOP/PRMUZ(JL),200.) ZEXMU0=EXP(-ZARG) ZARG2=MIN(ZRK*ZTOP,200.) ZEXKP=EXP(ZARG2) ZEXKM = 1./ZEXKP ZXP2P = 1.+ZDT*ZRP ZXM2P = 1.-ZDT*ZRP ZAP2B = ZALPHA+ZDT*ZBETA ZAM2B = ZALPHA-ZDT*ZBETA C C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER C 120 CONTINUE C ZA11 = ZXP2P ZA12 = ZXM2P ZA13 = ZAP2B ZA22 = ZXP2P*ZEXKP ZA21 = ZXM2P*ZEXKM ZA23 = ZAM2B*ZEXMU0 ZDENA = ZA11 * ZA22 - ZA21 * ZA12 ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA ZRI0A = ZC1A+ZC2A-ZALPHA ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL) ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0 ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0 PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL) C C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER C 130 CONTINUE C ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) ) ZDENB = ZA11 * ZB22 - ZB21 * ZA12 ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB ZRI0C = ZC1B+ZC2B-ZALPHA ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL) ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0 ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0 PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL) C 131 CONTINUE RETURN END SUBROUTINE SWTT (KNU,KA,PU,PTR) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL C INTERVALS. C C METHOD. C ------- C C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS C AND HORNER'S ALGORITHM. C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 88-12-15 C----------------------------------------------------------------------- C C* ARGUMENTS C INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL INTEGER KA ! INDEX OF THE ABSORBER REAL*8 PU(KDLON) ! ABSORBER AMOUNT C REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION C C* LOCAL VARIABLES: C REAL*8 ZR1(KDLON), ZR2(KDLON) INTEGER jl, i,j C C* Prescribed Data: C REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3) SAVE APAD, BPAD, D DATA ((APAD(1,I,J),I=1,3),J=1,7) / S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00, S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02, S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02, S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 / DATA ((APAD(2,I,J),I=1,3),J=1,7) / S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00, S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00, S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00, S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 / C DATA ((BPAD(1,I,J),I=1,3),J=1,7) / S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00, S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02, S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02, S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 / DATA ((BPAD(2,I,J),I=1,3),J=1,7) / S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01, S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00, S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00, S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 / c DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 / DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 / C C----------------------------------------------------------------------- C C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION C 100 CONTINUE C DO 201 JL = 1, KDLON ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL) S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL) S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL) S * ( APAD(KNU,KA,7) )))))) C ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL) S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL) S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL) S * ( BPAD(KNU,KA,7) )))))) C C C* 2. ADD THE BACKGROUND TRANSMISSION C 200 CONTINUE C C PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA) 201 CONTINUE C RETURN END SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL C INTERVALS. C C METHOD. C ------- C C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS C AND HORNER'S ALGORITHM. C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 95-01-20 C----------------------------------------------------------------------- C* ARGUMENTS: C INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL INTEGER KABS ! NUMBER OF ABSORBERS INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS REAL*8 PU(KDLON,KABS) ! ABSORBER AMOUNT C REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION C C* LOCAL VARIABLES: C REAL*8 ZR1(KDLON) REAL*8 ZR2(KDLON) REAL*8 ZU(KDLON) INTEGER jl, ja, i, j, ia C C* Prescribed Data: C REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3) SAVE APAD, BPAD, D DATA ((APAD(1,I,J),I=1,3),J=1,7) / S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00, S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02, S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02, S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 / DATA ((APAD(2,I,J),I=1,3),J=1,7) / S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00, S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00, S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00, S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 / C DATA ((BPAD(1,I,J),I=1,3),J=1,7) / S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04, S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00, S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02, S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02, S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 / DATA ((BPAD(2,I,J),I=1,3),J=1,7) / S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03, S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01, S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00, S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00, S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 / c DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 / DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 / C----------------------------------------------------------------------- C C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION C 100 CONTINUE C DO 202 JA = 1,KABS IA=KIND(JA) DO 201 JL = 1, KDLON ZU(JL) = PU(JL,JA) ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL) S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL) S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL) S * ( APAD(KNU,IA,7) )))))) C ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL) S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL) S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL) S * ( BPAD(KNU,IA,7) )))))) C C C* 2. ADD THE BACKGROUND TRANSMISSION C 200 CONTINUE C PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 201 CONTINUE 202 CONTINUE C RETURN END SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, . PPMB, PDP, . PPSOL,PDT0,PEMIS, . PTL, PTAVE, PWV, POZON, PAER, . PCLDLD,PCLDLU, . PVIEW, . PCOLR, PCOLR0, . PTOPLW,PSOLLW,PTOPLW0,PSOLLW0) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" include "YOMCST.h" C C----------------------------------------------------------------------- C METHOD. C ------- C C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF C ABSORBERS. C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE C BOUNDARIES. C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES. C C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C----------------------------------------------------------------------- REAL*8 RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97) REAL*8 RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97) REAL*8 RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97) REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97) REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97) REAL*8 PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER REAL*8 PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER REAL*8 PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa) REAL*8 PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K) REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY REAL*8 PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb) REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (Pa) REAL*8 POZON(KDLON,KFLEV) ! O3 CONCENTRATION (kg/kg) REAL*8 PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K) REAL*8 PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) REAL*8 PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg) C REAL*8 PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) REAL*8 PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky REAL*8 PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A. REAL*8 PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE REAL*8 PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY) REAL*8 PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY) C C------------------------------------------------------------------------- REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1) REAL*8 ZOZ(KDLON,KFLEV) c REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down) REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES REAL*8 ZBINT(KDLON,KFLEV+1) ! Intermediate variable REAL*8 ZBSUI(KDLON) ! Intermediate variable REAL*8 ZCTS(KDLON,KFLEV) ! Intermediate variable REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB c INTEGER ilim, i, k, kpl1 C INTEGER lw0pas ! Every lw0pas steps, clear-sky is done PARAMETER (lw0pas=1) INTEGER lwpas ! Every lwpas steps, cloudy-sky is done PARAMETER (lwpas=1) c INTEGER itaplw0, itaplw LOGICAL appel1er SAVE appel1er, itaplw0, itaplw DATA appel1er /.TRUE./ DATA itaplw0,itaplw /0,0/ C ------------------------------------------------------------------ IF (appel1er) THEN PRINT*, "LW clear-sky calling frequency: ", lw0pas PRINT*, "LW cloudy-sky calling frequency: ", lwpas PRINT*, " In general, they should be 1" appel1er=.FALSE. ENDIF C IF (MOD(itaplw0,lw0pas).EQ.0) THEN DO k = 1, KFLEV ! convertir ozone de kg/kg en pa/pa DO i = 1, KDLON ZOZ(i,k) = POZON(i,k)*PDP(i,k) * 28.9644/47.9942 ENDDO ENDDO CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12, S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU) CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU, S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB) itaplw0 = 0 ENDIF itaplw0 = itaplw0 + 1 C IF (MOD(itaplw,lwpas).EQ.0) THEN CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS, S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB, S ZFLUX) itaplw = 0 ENDIF itaplw = itaplw + 1 C DO k = 1, KFLEV kpl1 = k+1 DO i = 1, KDLON PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1) . - ZFLUX(i,1,k)- ZFLUX(i,2,k) PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k) PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1) . - ZFLUC(i,1,k)- ZFLUC(i,2,k) PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k) ENDDO ENDDO DO i = 1, KDLON PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1) PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1) c PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1) PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1) ENDDO C ------------------------------------------------------------------ RETURN END SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12, S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV, S PABCU) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" include "YOMCST.h" include "radepsi.h" include "radopt.h" C C PURPOSE. C -------- C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND C TEMPERATURE EFFECTS C C METHOD. C ------- C C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF C ABSORBERS. C C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C Voigt lines (loop 404 modified) - JJM & PhD - 01/96 C----------------------------------------------------------------------- C* ARGUMENTS: REAL*8 RCO2 REAL*8 RCH4, RN2O, RCFC11, RCFC12 REAL*8 PAER(KDLON,KFLEV,5) REAL*8 PDP(KDLON,KFLEV) REAL*8 PPMB(KDLON,KFLEV+1) REAL*8 PPSOL(KDLON) REAL*8 POZ(KDLON,KFLEV) REAL*8 PTAVE(KDLON,KFLEV) REAL*8 PVIEW(KDLON) REAL*8 PWV(KDLON,KFLEV) C REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS C C----------------------------------------------------------------------- C* LOCAL VARIABLES: REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1) REAL*8 ZDUC(KDLON,3*KFLEV+1) REAL*8 ZPHIO(KDLON) REAL*8 ZPSC2(KDLON) REAL*8 ZPSC3(KDLON) REAL*8 ZPSH1(KDLON) REAL*8 ZPSH2(KDLON) REAL*8 ZPSH3(KDLON) REAL*8 ZPSH4(KDLON) REAL*8 ZPSH5(KDLON) REAL*8 ZPSH6(KDLON) REAL*8 ZPSIO(KDLON) REAL*8 ZTCON(KDLON) REAL*8 ZPHM6(KDLON) REAL*8 ZPSM6(KDLON) REAL*8 ZPHN6(KDLON) REAL*8 ZPSN6(KDLON) REAL*8 ZSSIG(KDLON,3*KFLEV+1) REAL*8 ZTAVI(KDLON) REAL*8 ZUAER(KDLON,Ninter) REAL*8 ZXOZ(KDLON) REAL*8 ZXWV(KDLON) C INTEGER jl, jk, jkj, jkjr, jkjp, ig1 INTEGER jki, jkip1, ja, jj INTEGER jkl, jkp1, jkk, jkjpn INTEGER jae1, jae2, jae3, jae, jjpn INTEGER ir, jc, jcp1 REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup REAL*8 zfppw, ztx, ztx2, zzably REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3 REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6 REAL*8 zcac8, zcbc8 REAL*8 zalup, zdiff c REAL*8 PVGCO2, PVGH2O, PVGO3 C REAL*8 R10E ! DECIMAL/NATURAL LOG.FACTOR PARAMETER (R10E=0.4342945) c c Used Data Block: c REAL*8 TREF SAVE TREF REAL*8 RT1(2) SAVE RT1 REAL*8 RAER(5,5) SAVE RAER REAL*8 AT(8,3), BT(8,3) SAVE AT, BT REAL*8 OCT(4) SAVE OCT DATA TREF /250.0/ DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 / DATA RAER / .038520, .037196, .040532, .054934, .038520 1 , .12613 , .18313 , .10357 , .064106, .126130 2 , .012579, .013649, .018652, .025181, .012579 3 , .011890, .016142, .021105, .028908, .011890 4 , .013792, .026810, .052203, .066338, .013792 / DATA (AT(1,IR),IR=1,3) / S 0.298199E-02,-.394023E-03,0.319566E-04 / DATA (BT(1,IR),IR=1,3) / S-0.106432E-04,0.660324E-06,0.174356E-06 / DATA (AT(2,IR),IR=1,3) / S 0.143676E-01,0.366501E-02,-.160822E-02 / DATA (BT(2,IR),IR=1,3) / S-0.553979E-04,-.101701E-04,0.920868E-05 / DATA (AT(3,IR),IR=1,3) / S 0.197861E-01,0.315541E-02,-.174547E-02 / DATA (BT(3,IR),IR=1,3) / S-0.877012E-04,0.513302E-04,0.523138E-06 / DATA (AT(4,IR),IR=1,3) / S 0.289560E-01,-.208807E-02,-.121943E-02 / DATA (BT(4,IR),IR=1,3) / S-0.165960E-03,0.157704E-03,-.146427E-04 / DATA (AT(5,IR),IR=1,3) / S 0.103800E-01,0.436296E-02,-.161431E-02 / DATA (BT(5,IR),IR=1,3) / S -.276744E-04,-.327381E-04,0.127646E-04 / DATA (AT(6,IR),IR=1,3) / S 0.868859E-02,-.972752E-03,0.000000E-00 / DATA (BT(6,IR),IR=1,3) / S -.278412E-04,-.713940E-06,0.117469E-05 / DATA (AT(7,IR),IR=1,3) / S 0.250073E-03,0.455875E-03,0.109242E-03 / DATA (BT(7,IR),IR=1,3) / S 0.199846E-05,-.216313E-05,0.175991E-06 / DATA (AT(8,IR),IR=1,3) / S 0.307423E-01,0.110879E-02,-.322172E-03 / DATA (BT(8,IR),IR=1,3) / S-0.108482E-03,0.258096E-05,-.814575E-06 / c DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/ C----------------------------------------------------------------------- c IF (LEVOIGT) THEN PVGCO2= 60. PVGH2O= 30. PVGO3 =400. ELSE PVGCO2= 0. PVGH2O= 0. PVGO3 = 0. ENDIF C C C* 2. PRESSURE OVER GAUSS SUB-LEVELS C ------------------------------ C 200 CONTINUE C DO 201 JL = 1, KDLON ZSSIG(JL, 1 ) = PPMB(JL,1) * 100. 201 CONTINUE C DO 206 JK = 1 , KFLEV JKJ=(JK-1)*NG1P1+1 JKJR = JKJ JKJP = JKJ + NG1P1 DO 203 JL = 1, KDLON ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100. 203 CONTINUE DO 205 IG1=1,NG1 JKJ=JKJ+1 DO 204 JL = 1, KDLON ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5 S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5 204 CONTINUE 205 CONTINUE 206 CONTINUE C C----------------------------------------------------------------------- C C C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS C -------------------------------------------------- C 400 CONTINUE C DO 402 JKI=1,3*KFLEV JKIP1=JKI+1 DO 401 JL = 1, KDLON ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5 ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1)) S /(10.*RG) 401 CONTINUE 402 CONTINUE C DO 406 JK = 1 , KFLEV JKP1=JK+1 JKL = KFLEV+1 - JK DO 403 JL = 1, KDLON ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ ) ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO ) 403 CONTINUE JKJ=(JK-1)*NG1P1+1 JKJPN=JKJ+NG1 DO 405 JKK=JKJ,JKJPN DO 404 JL = 1, KDLON ZDPM = ZABLY(JL,3,JKK) ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325. ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325. ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325. ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325. ZDUC(JL,JKK) = ZDPM ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3 ZU6 = ZXWV(JL) * ZUPM ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL)) ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O ZABLY(JL,11,JKK) = ZU6 * ZFPPW ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW) ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2 ZABLY(JL,8,JKK) = RCO2 * ZDPM 404 CONTINUE 405 CONTINUE 406 CONTINUE C C----------------------------------------------------------------------- C C C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE C -------------------------------------------------- C 500 CONTINUE C DO 502 JA = 1, NUA DO 501 JL = 1, KDLON PABCU(JL,JA,3*KFLEV+1) = 0. 501 CONTINUE 502 CONTINUE C DO 529 JK = 1 , KFLEV JJ=(JK-1)*NG1P1+1 JJPN=JJ+NG1 JKL=KFLEV+1-JK C C C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE C -------------------------------------------------- C 510 CONTINUE C JAE1=3*KFLEV+1-JJ JAE2=3*KFLEV+1-(JJ+1) JAE3=3*KFLEV+1-JJPN DO 512 JAE=1,5 DO 511 JL = 1, KDLON ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1) S +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3) S +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5)) S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3)) 511 CONTINUE 512 CONTINUE C C C C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS C -------------------------------------------------- C 520 CONTINUE C DO 521 JL = 1, KDLON ZTAVI(JL)=PTAVE(JL,JKL) ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.)) ZTX=ZTAVI(JL)-TREF ZTX2=ZTX*ZTX ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3) ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0) ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3))) ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3))) ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 ) ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3))) ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3))) ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 ) ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3))) ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3))) ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 ) ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3))) ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3))) ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 ) ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3))) ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3))) ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 ) ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3))) ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3))) ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 ) ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 ) ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 ) ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 ) ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 ) 521 CONTINUE C DO 522 JL = 1, KDLON ZTAVI(JL)=PTAVE(JL,JKL) ZTX=ZTAVI(JL)-TREF ZTX2=ZTX*ZTX ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3) ZALUP = R10E * LOG ( ZZABLY ) ZUP = MAX( 0.0 , 5.0 + 0.5 * ZALUP ) ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3))) ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3))) ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 ) ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2) ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2)) 522 CONTINUE C DO 524 JKK=JJ,JJPN JC=3*KFLEV+1-JKK JCP1=JC+1 DO 523 JL = 1, KDLON ZDIFF = PVIEW(JL) PABCU(JL,10,JC)=PABCU(JL,10,JCP1) S +ZABLY(JL,10,JC) *ZDIFF PABCU(JL,11,JC)=PABCU(JL,11,JCP1) S +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF C PABCU(JL,12,JC)=PABCU(JL,12,JCP1) S +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF PABCU(JL,13,JC)=PABCU(JL,13,JCP1) S +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF C PABCU(JL,7,JC)=PABCU(JL,7,JCP1) S +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF PABCU(JL,8,JC)=PABCU(JL,8,JCP1) S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF PABCU(JL,9,JC)=PABCU(JL,9,JCP1) S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF C PABCU(JL,1,JC)=PABCU(JL,1,JCP1) S +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF PABCU(JL,2,JC)=PABCU(JL,2,JCP1) S +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF PABCU(JL,3,JC)=PABCU(JL,3,JCP1) S +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF PABCU(JL,4,JC)=PABCU(JL,4,JCP1) S +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF PABCU(JL,5,JC)=PABCU(JL,5,JCP1) S +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF PABCU(JL,6,JC)=PABCU(JL,6,JCP1) S +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF C PABCU(JL,14,JC)=PABCU(JL,14,JCP1) S +ZUAER(JL,1) *ZDUC(JL,JC)*ZDIFF PABCU(JL,15,JC)=PABCU(JL,15,JCP1) S +ZUAER(JL,2) *ZDUC(JL,JC)*ZDIFF PABCU(JL,16,JC)=PABCU(JL,16,JCP1) S +ZUAER(JL,3) *ZDUC(JL,JC)*ZDIFF PABCU(JL,17,JC)=PABCU(JL,17,JCP1) S +ZUAER(JL,4) *ZDUC(JL,JC)*ZDIFF PABCU(JL,18,JC)=PABCU(JL,18,JCP1) S +ZUAER(JL,5) *ZDUC(JL,JC)*ZDIFF C PABCU(JL,19,JC)=PABCU(JL,19,JCP1) S +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF PABCU(JL,20,JC)=PABCU(JL,20,JCP1) S +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF PABCU(JL,21,JC)=PABCU(JL,21,JCP1) S +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF PABCU(JL,22,JC)=PABCU(JL,22,JCP1) S +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF C PABCU(JL,23,JC)=PABCU(JL,23,JCP1) S +ZABLY(JL,8,JC)*RCFC11/RCO2 *ZDIFF PABCU(JL,24,JC)=PABCU(JL,24,JCP1) S +ZABLY(JL,8,JC)*RCFC12/RCO2 *ZDIFF 523 CONTINUE 524 CONTINUE C 529 CONTINUE C C RETURN END SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU, S PFLUC,PBINT,PBSUI,PCTS,PCNTRB) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" include "YOMCST.h" C C PURPOSE. C -------- C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY C SAVING C C METHOD. C ------- C C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE C BOUNDARIES. C 3. COMPUTES THE CLEAR-SKY COOLING RATES. C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE C MEMORY) C----------------------------------------------------------------------- C* ARGUMENTS: INTEGER KLIM C REAL*8 PDP(KDLON,KFLEV) REAL*8 PDT0(KDLON) REAL*8 PEMIS(KDLON) REAL*8 PPMB(KDLON,KFLEV+1) REAL*8 PTL(KDLON,KFLEV+1) REAL*8 PTAVE(KDLON,KFLEV) C REAL*8 PFLUC(KDLON,2,KFLEV+1) C REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) REAL*8 PBINT(KDLON,KFLEV+1) REAL*8 PBSUI(KDLON) REAL*8 PCTS(KDLON,KFLEV) REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) C C------------------------------------------------------------------------- C C* LOCAL VARIABLES: REAL*8 ZB(KDLON,Ninter,KFLEV+1) REAL*8 ZBSUR(KDLON,Ninter) REAL*8 ZBTOP(KDLON,Ninter) REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2) REAL*8 ZGA(KDLON,8,2,KFLEV) REAL*8 ZGB(KDLON,8,2,KFLEV) REAL*8 ZGASUR(KDLON,8,2) REAL*8 ZGBSUR(KDLON,8,2) REAL*8 ZGATOP(KDLON,8,2) REAL*8 ZGBTOP(KDLON,8,2) C INTEGER nuaer, ntraer C ------------------------------------------------------------------ C* COMPUTES PLANCK FUNCTIONS: CALL LWB(PDT0,PTAVE,PTL, S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL, S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP) C ------------------------------------------------------------------ C* PERFORMS THE VERTICAL INTEGRATION: NUAER = NUA NTRAER = NTRA CALL LWV(NUAER,NTRAER, KLIM R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP S , PCNTRB,PCTS,PFLUC) C ------------------------------------------------------------------ RETURN END SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC, R PBINT,PBSUIN,PCTS,PCNTRB, S PFLUX) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "radepsi.h" include "radopt.h" C C PURPOSE. C -------- C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR C RADIANCES C C EXPLICIT ARGUMENTS : C -------------------- C ==== INPUTS === C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE C PEMIS : (KDLON) ; SURFACE EMISSIVITY C PFLUC C ==== OUTPUTS === C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES : C 1 ==> UPWARD FLUX TOTAL C 2 ==> DOWNWARD FLUX TOTAL C C METHOD. C ------- C C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED C CLOUDS C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96 C----------------------------------------------------------------------- C* ARGUMENTS: INTEGER klim REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE REAL*8 PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE c REAL*8 PCLDLD(KDLON,KFLEV) REAL*8 PCLDLU(KDLON,KFLEV) REAL*8 PEMIS(KDLON) C REAL*8 PFLUX(KDLON,2,KFLEV+1) C----------------------------------------------------------------------- C* LOCAL VARIABLES: INTEGER IMX(KDLON), IMXP(KDLON) C REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1) S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON) S , ZUPF(KDLON,KFLEV+1,KFLEV+1) REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1) C INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1 INTEGER jk1, jk2, jkc, jkcp1, jcloud INTEGER imxm1, imxp1 REAL*8 zcfrac C ------------------------------------------------------------------ C C* 1. INITIALIZATION C -------------- C 100 CONTINUE C IMAXC = 0 C DO 101 JL = 1, KDLON IMX(JL)=0 IMXP(JL)=0 ZCLOUD(JL) = 0. 101 CONTINUE C C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD C ------------------------------------------- C 110 CONTINUE C DO 112 JK = 1 , KFLEV DO 111 JL = 1, KDLON IMX1=IMX(JL) IMX2=JK IF (PCLDLU(JL,JK).GT.ZEPSC) THEN IMXP(JL)=IMX2 ELSE IMXP(JL)=IMX1 END IF IMAXC=MAX(IMXP(JL),IMAXC) IMX(JL)=IMXP(JL) 111 CONTINUE 112 CONTINUE CGM******* IMAXC=KFLEV CGM******* C DO 114 JK = 1 , KFLEV+1 DO 113 JL = 1, KDLON PFLUX(JL,1,JK) = PFLUC(JL,1,JK) PFLUX(JL,2,JK) = PFLUC(JL,2,JK) 113 CONTINUE 114 CONTINUE C C ------------------------------------------------------------------ C C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES C --------------------------------------- C IF (IMAXC.GT.0) THEN C IMXP1 = IMAXC + 1 IMXM1 = IMAXC - 1 C C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES C ------------------------------ C 200 CONTINUE C DO 203 JK1=1,KFLEV+1 DO 202 JK2=1,KFLEV+1 DO 201 JL = 1, KDLON ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1) ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1) 201 CONTINUE 202 CONTINUE 203 CONTINUE C C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD C ---------------------------------------------- C 210 CONTINUE C DO 213 JKC = 1 , IMAXC JCLOUD=JKC JKCP1=JCLOUD+1 C C* 2.1.1 ABOVE THE CLOUD C --------------- C 2110 CONTINUE C DO 2115 JK=JKCP1,KFLEV+1 JKM1=JK-1 DO 2111 JL = 1, KDLON ZFU(JL)=0. 2111 CONTINUE IF (JK .GT. JKCP1) THEN DO 2113 JKJ=JKCP1,JKM1 DO 2112 JL = 1, KDLON ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ) 2112 CONTINUE 2113 CONTINUE END IF C DO 2114 JL = 1, KDLON ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL) 2114 CONTINUE 2115 CONTINUE C C* 2.1.2 BELOW THE CLOUD C --------------- C 2120 CONTINUE C DO 2125 JK=1,JCLOUD JKP1=JK+1 DO 2121 JL = 1, KDLON ZFD(JL)=0. 2121 CONTINUE C IF (JK .LT. JCLOUD) THEN DO 2123 JKJ=JKP1,JCLOUD DO 2122 JL = 1, KDLON ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ) 2122 CONTINUE 2123 CONTINUE END IF DO 2124 JL = 1, KDLON ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL) 2124 CONTINUE 2125 CONTINUE C 213 CONTINUE C C C* 2.2 CLOUD COVER MATRIX C ------------------ C C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1 C 220 CONTINUE C DO 223 JK1 = 1 , KFLEV+1 DO 222 JK2 = 1 , KFLEV+1 DO 221 JL = 1, KDLON ZCLM(JL,JK1,JK2) = 0. 221 CONTINUE 222 CONTINUE 223 CONTINUE C C C C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION C ------------------------------------------ C 240 CONTINUE C DO 244 JK1 = 2 , KFLEV+1 DO 241 JL = 1, KDLON ZCLEAR(JL)=1. ZCLOUD(JL)=0. 241 CONTINUE DO 243 JK = JK1 - 1 , 1 , -1 DO 242 JL = 1, KDLON IF (NOVLP.EQ.1) THEN c* maximum-random ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL))) * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) ZCLOUD(JL) = PCLDLU(JL,JK) ELSE IF (NOVLP.EQ.2) THEN c* maximum ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK)) ZCLM(JL,JK1,JK) = ZCLOUD(JL) ELSE IF (NOVLP.EQ.3) THEN c* random ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK)) ZCLOUD(JL) = 1.0 - ZCLEAR(JL) ZCLM(JL,JK1,JK) = ZCLOUD(JL) END IF 242 CONTINUE 243 CONTINUE 244 CONTINUE C C C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION C ------------------------------------------ C 250 CONTINUE C DO 254 JK1 = 1 , KFLEV DO 251 JL = 1, KDLON ZCLEAR(JL)=1. ZCLOUD(JL)=0. 251 CONTINUE DO 253 JK = JK1 , KFLEV DO 252 JL = 1, KDLON IF (NOVLP.EQ.1) THEN c* maximum-random ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL))) * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) ZCLOUD(JL) = PCLDLD(JL,JK) ELSE IF (NOVLP.EQ.2) THEN c* maximum ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK)) ZCLM(JL,JK1,JK) = ZCLOUD(JL) ELSE IF (NOVLP.EQ.3) THEN c* random ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK)) ZCLOUD(JL) = 1.0 - ZCLEAR(JL) ZCLM(JL,JK1,JK) = ZCLOUD(JL) END IF 252 CONTINUE 253 CONTINUE 254 CONTINUE C C C C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS C ---------------------------------------------- C 300 CONTINUE C C* 3.1 DOWNWARD FLUXES C --------------- C 310 CONTINUE C DO 311 JL = 1, KDLON PFLUX(JL,2,KFLEV+1) = 0. 311 CONTINUE C DO 317 JK1 = KFLEV , 1 , -1 C C* CONTRIBUTION FROM CLEAR-SKY FRACTION C DO 312 JL = 1, KDLON ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1) 312 CONTINUE C C* CONTRIBUTION FROM ADJACENT CLOUD C DO 313 JL = 1, KDLON ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1) 313 CONTINUE C C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS C DO 315 JK = KFLEV-1 , JK1 , -1 DO 314 JL = 1, KDLON ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK) ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1) 314 CONTINUE 315 CONTINUE C DO 316 JL = 1, KDLON PFLUX(JL,2,JK1) = ZFD (JL) 316 CONTINUE C 317 CONTINUE C C C C C* 3.2 UPWARD FLUX AT THE SURFACE C -------------------------- C 320 CONTINUE C DO 321 JL = 1, KDLON PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1) 321 CONTINUE C C C C* 3.3 UPWARD FLUXES C ------------- C 330 CONTINUE C DO 337 JK1 = 2 , KFLEV+1 C C* CONTRIBUTION FROM CLEAR-SKY FRACTION C DO 332 JL = 1, KDLON ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1) 332 CONTINUE C C* CONTRIBUTION FROM ADJACENT CLOUD C DO 333 JL = 1, KDLON ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1) 333 CONTINUE C C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS C DO 335 JK = 2 , JK1-1 DO 334 JL = 1, KDLON ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK) ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1) 334 CONTINUE 335 CONTINUE C DO 336 JL = 1, KDLON PFLUX(JL,1,JK1) = ZFU (JL) 336 CONTINUE C 337 CONTINUE C C END IF C C C* 2.3 END OF CLOUD EFFECT COMPUTATIONS C 230 CONTINUE C IF (.NOT.LEVOIGT) THEN DO 231 JL = 1, KDLON ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM) 231 CONTINUE DO 233 JK = KLIM+1 , KFLEV+1 DO 232 JL = 1, KDLON ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) PFLUX(JL,1,JK) = ZFN10(JL) PFLUX(JL,2,JK) = 0.0 232 CONTINUE 233 CONTINUE ENDIF C RETURN END SUBROUTINE LWB(PDT0,PTAVE,PTL S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C COMPUTES PLANCK FUNCTIONS C C EXPLICIT ARGUMENTS : C -------------------- C ==== INPUTS === C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY C PTAVE : (KDLON,KFLEV) ; TEMPERATURE C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE C ==== OUTPUTS === C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS C C IMPLICIT ARGUMENTS : NONE C -------------------- C C METHOD. C ------- C C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS " C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C C----------------------------------------------------------------------- C C ARGUMENTS: C REAL*8 PDT0(KDLON) REAL*8 PTAVE(KDLON,KFLEV) REAL*8 PTL(KDLON,KFLEV+1) C REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS C C------------------------------------------------------------------------- C* LOCAL VARIABLES: INTEGER INDB(KDLON),INDS(KDLON) REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1) REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON) c INTEGER jk, jl, ic, jnu, jf, jg INTEGER jk1, jk2 INTEGER k, j, ixtox, indto, ixtx, indt INTEGER indsu, indtp REAL*8 zdsto1, zdstox, zdst1, zdstx c C* Quelques parametres: REAL*8 TSTAND PARAMETER (TSTAND=250.0) REAL*8 TSTP PARAMETER (TSTP=12.5) INTEGER MXIXT PARAMETER (MXIXT=10) C C* Used Data Block: REAL*8 TINTP(11) SAVE TINTP REAL*8 GA(11,16,3), GB(11,16,3) SAVE GA, GB REAL*8 XP(6,6) SAVE XP c DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250., S 262.5, 275., 287.5, 300., 312.5 / C----------------------------------------------------------------------- C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ---------------- C C C C C-- R.D. -- G = - 0.2 SLA C C C----- INTERVAL = 1 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 1, 1,IC),IC=1,3) / S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/ DATA (GB( 1, 1,IC),IC=1,3) / S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/ DATA (GA( 1, 2,IC),IC=1,3) / S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/ DATA (GB( 1, 2,IC),IC=1,3) / S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 2, 1,IC),IC=1,3) / S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/ DATA (GB( 2, 1,IC),IC=1,3) / S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/ DATA (GA( 2, 2,IC),IC=1,3) / S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/ DATA (GB( 2, 2,IC),IC=1,3) / S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 3, 1,IC),IC=1,3) / S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/ DATA (GB( 3, 1,IC),IC=1,3) / S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/ DATA (GA( 3, 2,IC),IC=1,3) / S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/ DATA (GB( 3, 2,IC),IC=1,3) / S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 4, 1,IC),IC=1,3) / S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/ DATA (GB( 4, 1,IC),IC=1,3) / S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/ DATA (GA( 4, 2,IC),IC=1,3) / S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/ DATA (GB( 4, 2,IC),IC=1,3) / S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 5, 1,IC),IC=1,3) / S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/ DATA (GB( 5, 1,IC),IC=1,3) / S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/ DATA (GA( 5, 2,IC),IC=1,3) / S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/ DATA (GB( 5, 2,IC),IC=1,3) / S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 6, 1,IC),IC=1,3) / S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/ DATA (GB( 6, 1,IC),IC=1,3) / S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/ DATA (GA( 6, 2,IC),IC=1,3) / S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/ DATA (GB( 6, 2,IC),IC=1,3) / S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 7, 1,IC),IC=1,3) / S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/ DATA (GB( 7, 1,IC),IC=1,3) / S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/ DATA (GA( 7, 2,IC),IC=1,3) / S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/ DATA (GB( 7, 2,IC),IC=1,3) / S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 8, 1,IC),IC=1,3) / S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/ DATA (GB( 8, 1,IC),IC=1,3) / S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/ DATA (GA( 8, 2,IC),IC=1,3) / S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/ DATA (GB( 8, 2,IC),IC=1,3) / S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 9, 1,IC),IC=1,3) / S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/ DATA (GB( 9, 1,IC),IC=1,3) / S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/ DATA (GA( 9, 2,IC),IC=1,3) / S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/ DATA (GB( 9, 2,IC),IC=1,3) / S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA(10, 1,IC),IC=1,3) / S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/ DATA (GB(10, 1,IC),IC=1,3) / S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/ DATA (GA(10, 2,IC),IC=1,3) / S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/ DATA (GB(10, 2,IC),IC=1,3) / S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/ C C----- INTERVAL = 1 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA(11, 1,IC),IC=1,3) / S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/ DATA (GB(11, 1,IC),IC=1,3) / S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/ DATA (GA(11, 2,IC),IC=1,3) / S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/ DATA (GB(11, 2,IC),IC=1,3) / S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/ C C C C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 --------- C C C C C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U ) C C C----- INTERVAL = 2 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 1, 3,IC),IC=1,3) / S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/ DATA (GB( 1, 3,IC),IC=1,3) / S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/ DATA (GA( 1, 4,IC),IC=1,3) / S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/ DATA (GB( 1, 4,IC),IC=1,3) / S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 2, 3,IC),IC=1,3) / S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/ DATA (GB( 2, 3,IC),IC=1,3) / S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/ DATA (GA( 2, 4,IC),IC=1,3) / S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/ DATA (GB( 2, 4,IC),IC=1,3) / S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 3, 3,IC),IC=1,3) / S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/ DATA (GB( 3, 3,IC),IC=1,3) / S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/ DATA (GA( 3, 4,IC),IC=1,3) / S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/ DATA (GB( 3, 4,IC),IC=1,3) / S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 4, 3,IC),IC=1,3) / S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/ DATA (GB( 4, 3,IC),IC=1,3) / S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/ DATA (GA( 4, 4,IC),IC=1,3) / S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/ DATA (GB( 4, 4,IC),IC=1,3) / S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 5, 3,IC),IC=1,3) / S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/ DATA (GB( 5, 3,IC),IC=1,3) / S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/ DATA (GA( 5, 4,IC),IC=1,3) / S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/ DATA (GB( 5, 4,IC),IC=1,3) / S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 6, 3,IC),IC=1,3) / S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/ DATA (GB( 6, 3,IC),IC=1,3) / S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/ DATA (GA( 6, 4,IC),IC=1,3) / S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/ DATA (GB( 6, 4,IC),IC=1,3) / S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 7, 3,IC),IC=1,3) / S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/ DATA (GB( 7, 3,IC),IC=1,3) / S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/ DATA (GA( 7, 4,IC),IC=1,3) / S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/ DATA (GB( 7, 4,IC),IC=1,3) / S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 8, 3,IC),IC=1,3) / S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/ DATA (GB( 8, 3,IC),IC=1,3) / S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/ DATA (GA( 8, 4,IC),IC=1,3) / S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/ DATA (GB( 8, 4,IC),IC=1,3) / S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 9, 3,IC),IC=1,3) / S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/ DATA (GB( 9, 3,IC),IC=1,3) / S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/ DATA (GA( 9, 4,IC),IC=1,3) / S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/ DATA (GB( 9, 4,IC),IC=1,3) / S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA(10, 3,IC),IC=1,3) / S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/ DATA (GB(10, 3,IC),IC=1,3) / S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/ DATA (GA(10, 4,IC),IC=1,3) / S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/ DATA (GB(10, 4,IC),IC=1,3) / S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA(11, 3,IC),IC=1,3) / S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/ DATA (GB(11, 3,IC),IC=1,3) / S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/ DATA (GA(11, 4,IC),IC=1,3) / S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/ DATA (GB(11, 4,IC),IC=1,3) / S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/ C C C C C C C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS - C C C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1) C C C C--- G = 3.875E-03 --------------- C C----- INTERVAL = 3 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 1, 7,IC),IC=1,3) / S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/ DATA (GB( 1, 7,IC),IC=1,3) / S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/ DATA (GA( 1, 8,IC),IC=1,3) / S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/ DATA (GB( 1, 8,IC),IC=1,3) / S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 2, 7,IC),IC=1,3) / S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/ DATA (GB( 2, 7,IC),IC=1,3) / S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/ DATA (GA( 2, 8,IC),IC=1,3) / S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/ DATA (GB( 2, 8,IC),IC=1,3) / S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 3, 7,IC),IC=1,3) / S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/ DATA (GB( 3, 7,IC),IC=1,3) / S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/ DATA (GA( 3, 8,IC),IC=1,3) / S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/ DATA (GB( 3, 8,IC),IC=1,3) / S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 4, 7,IC),IC=1,3) / S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/ DATA (GB( 4, 7,IC),IC=1,3) / S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/ DATA (GA( 4, 8,IC),IC=1,3) / S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/ DATA (GB( 4, 8,IC),IC=1,3) / S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 5, 7,IC),IC=1,3) / S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/ DATA (GB( 5, 7,IC),IC=1,3) / S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/ DATA (GA( 5, 8,IC),IC=1,3) / S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/ DATA (GB( 5, 8,IC),IC=1,3) / S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 6, 7,IC),IC=1,3) / S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/ DATA (GB( 6, 7,IC),IC=1,3) / S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/ DATA (GA( 6, 8,IC),IC=1,3) / S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/ DATA (GB( 6, 8,IC),IC=1,3) / S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 7, 7,IC),IC=1,3) / S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/ DATA (GB( 7, 7,IC),IC=1,3) / S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/ DATA (GA( 7, 8,IC),IC=1,3) / S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/ DATA (GB( 7, 8,IC),IC=1,3) / S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 8, 7,IC),IC=1,3) / S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/ DATA (GB( 8, 7,IC),IC=1,3) / S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/ DATA (GA( 8, 8,IC),IC=1,3) / S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/ DATA (GB( 8, 8,IC),IC=1,3) / S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 9, 7,IC),IC=1,3) / S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/ DATA (GB( 9, 7,IC),IC=1,3) / S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/ DATA (GA( 9, 8,IC),IC=1,3) / S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/ DATA (GB( 9, 8,IC),IC=1,3) / S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA(10, 7,IC),IC=1,3) / S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/ DATA (GB(10, 7,IC),IC=1,3) / S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/ DATA (GA(10, 8,IC),IC=1,3) / S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/ DATA (GB(10, 8,IC),IC=1,3) / S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/ C C----- INTERVAL = 3 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA(11, 7,IC),IC=1,3) / S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/ DATA (GB(11, 7,IC),IC=1,3) / S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/ DATA (GA(11, 8,IC),IC=1,3) / S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/ DATA (GB(11, 8,IC),IC=1,3) / S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/ C C C-- WATER VAPOR -- 970-1110 CM-1 ---------------------------------------- C C-- G = 3.6E-03 C C----- INTERVAL = 4 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 1, 9,IC),IC=1,3) / S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/ DATA (GB( 1, 9,IC),IC=1,3) / S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/ DATA (GA( 1,10,IC),IC=1,3) / S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/ DATA (GB( 1,10,IC),IC=1,3) / S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 2, 9,IC),IC=1,3) / S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/ DATA (GB( 2, 9,IC),IC=1,3) / S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/ DATA (GA( 2,10,IC),IC=1,3) / S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/ DATA (GB( 2,10,IC),IC=1,3) / S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 3, 9,IC),IC=1,3) / S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/ DATA (GB( 3, 9,IC),IC=1,3) / S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/ DATA (GA( 3,10,IC),IC=1,3) / S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/ DATA (GB( 3,10,IC),IC=1,3) / S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 4, 9,IC),IC=1,3) / S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/ DATA (GB( 4, 9,IC),IC=1,3) / S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/ DATA (GA( 4,10,IC),IC=1,3) / S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/ DATA (GB( 4,10,IC),IC=1,3) / S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 5, 9,IC),IC=1,3) / S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/ DATA (GB( 5, 9,IC),IC=1,3) / S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/ DATA (GA( 5,10,IC),IC=1,3) / S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/ DATA (GB( 5,10,IC),IC=1,3) / S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 6, 9,IC),IC=1,3) / S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/ DATA (GB( 6, 9,IC),IC=1,3) / S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/ DATA (GA( 6,10,IC),IC=1,3) / S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/ DATA (GB( 6,10,IC),IC=1,3) / S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 7, 9,IC),IC=1,3) / S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/ DATA (GB( 7, 9,IC),IC=1,3) / S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/ DATA (GA( 7,10,IC),IC=1,3) / S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/ DATA (GB( 7,10,IC),IC=1,3) / S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 8, 9,IC),IC=1,3) / S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/ DATA (GB( 8, 9,IC),IC=1,3) / S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/ DATA (GA( 8,10,IC),IC=1,3) / S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/ DATA (GB( 8,10,IC),IC=1,3) / S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA( 9, 9,IC),IC=1,3) / S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/ DATA (GB( 9, 9,IC),IC=1,3) / S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/ DATA (GA( 9,10,IC),IC=1,3) / S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/ DATA (GB( 9,10,IC),IC=1,3) / S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA(10, 9,IC),IC=1,3) / S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/ DATA (GB(10, 9,IC),IC=1,3) / S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/ DATA (GA(10,10,IC),IC=1,3) / S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/ DATA (GB(10,10,IC),IC=1,3) / S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 DATA (GA(11, 9,IC),IC=1,3) / S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/ DATA (GB(11, 9,IC),IC=1,3) / S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/ DATA (GA(11,10,IC),IC=1,3) / S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/ DATA (GB(11,10,IC),IC=1,3) / S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/ C C C C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ---- C C-- WATER VAPOR --- 350 - 500 CM-1 C C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U) C C----- INTERVAL = 5 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 1, 5,IC),IC=1,3) / S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/ DATA (GB( 1, 5,IC),IC=1,3) / S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/ DATA (GA( 1, 6,IC),IC=1,3) / S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/ DATA (GB( 1, 6,IC),IC=1,3) / S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 2, 5,IC),IC=1,3) / S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/ DATA (GB( 2, 5,IC),IC=1,3) / S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/ DATA (GA( 2, 6,IC),IC=1,3) / S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/ DATA (GB( 2, 6,IC),IC=1,3) / S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 3, 5,IC),IC=1,3) / S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/ DATA (GB( 3, 5,IC),IC=1,3) / S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/ DATA (GA( 3, 6,IC),IC=1,3) / S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/ DATA (GB( 3, 6,IC),IC=1,3) / S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 4, 5,IC),IC=1,3) / S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/ DATA (GB( 4, 5,IC),IC=1,3) / S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/ DATA (GA( 4, 6,IC),IC=1,3) / S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/ DATA (GB( 4, 6,IC),IC=1,3) / S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 5, 5,IC),IC=1,3) / S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/ DATA (GB( 5, 5,IC),IC=1,3) / S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/ DATA (GA( 5, 6,IC),IC=1,3) / S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/ DATA (GB( 5, 6,IC),IC=1,3) / S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 6, 5,IC),IC=1,3) / S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/ DATA (GB( 6, 5,IC),IC=1,3) / S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/ DATA (GA( 6, 6,IC),IC=1,3) / S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/ DATA (GB( 6, 6,IC),IC=1,3) / S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 7, 5,IC),IC=1,3) / S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/ DATA (GB( 7, 5,IC),IC=1,3) / S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/ DATA (GA( 7, 6,IC),IC=1,3) / S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/ DATA (GB( 7, 6,IC),IC=1,3) / S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 8, 5,IC),IC=1,3) / S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/ DATA (GB( 8, 5,IC),IC=1,3) / S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/ DATA (GA( 8, 6,IC),IC=1,3) / S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/ DATA (GB( 8, 6,IC),IC=1,3) / S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 9, 5,IC),IC=1,3) / S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/ DATA (GB( 9, 5,IC),IC=1,3) / S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/ DATA (GA( 9, 6,IC),IC=1,3) / S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/ DATA (GB( 9, 6,IC),IC=1,3) / S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA(10, 5,IC),IC=1,3) / S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/ DATA (GB(10, 5,IC),IC=1,3) / S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/ DATA (GA(10, 6,IC),IC=1,3) / S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/ DATA (GB(10, 6,IC),IC=1,3) / S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/ C C----- INTERVAL = 5 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA(11, 5,IC),IC=1,3) / S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/ DATA (GB(11, 5,IC),IC=1,3) / S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/ DATA (GA(11, 6,IC),IC=1,3) / S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/ DATA (GB(11, 6,IC),IC=1,3) / S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/ C C C C C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 - C--- G = 0.0 C C C----- INTERVAL = 6 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 1,11,IC),IC=1,3) / S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/ DATA (GB( 1,11,IC),IC=1,3) / S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/ DATA (GA( 1,12,IC),IC=1,3) / S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/ DATA (GB( 1,12,IC),IC=1,3) / S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 2,11,IC),IC=1,3) / S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/ DATA (GB( 2,11,IC),IC=1,3) / S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/ DATA (GA( 2,12,IC),IC=1,3) / S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/ DATA (GB( 2,12,IC),IC=1,3) / S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 3,11,IC),IC=1,3) / S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/ DATA (GB( 3,11,IC),IC=1,3) / S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/ DATA (GA( 3,12,IC),IC=1,3) / S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/ DATA (GB( 3,12,IC),IC=1,3) / S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 4,11,IC),IC=1,3) / S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/ DATA (GB( 4,11,IC),IC=1,3) / S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/ DATA (GA( 4,12,IC),IC=1,3) / S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/ DATA (GB( 4,12,IC),IC=1,3) / S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 5,11,IC),IC=1,3) / S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/ DATA (GB( 5,11,IC),IC=1,3) / S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/ DATA (GA( 5,12,IC),IC=1,3) / S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/ DATA (GB( 5,12,IC),IC=1,3) / S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 6,11,IC),IC=1,3) / S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/ DATA (GB( 6,11,IC),IC=1,3) / S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/ DATA (GA( 6,12,IC),IC=1,3) / S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/ DATA (GB( 6,12,IC),IC=1,3) / S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 7,11,IC),IC=1,3) / S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/ DATA (GB( 7,11,IC),IC=1,3) / S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/ DATA (GA( 7,12,IC),IC=1,3) / S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/ DATA (GB( 7,12,IC),IC=1,3) / S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 8,11,IC),IC=1,3) / S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/ DATA (GB( 8,11,IC),IC=1,3) / S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/ DATA (GA( 8,12,IC),IC=1,3) / S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/ DATA (GB( 8,12,IC),IC=1,3) / S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA( 9,11,IC),IC=1,3) / S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/ DATA (GB( 9,11,IC),IC=1,3) / S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/ DATA (GA( 9,12,IC),IC=1,3) / S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/ DATA (GB( 9,12,IC),IC=1,3) / S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA(10,11,IC),IC=1,3) / S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/ DATA (GB(10,11,IC),IC=1,3) / S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/ DATA (GA(10,12,IC),IC=1,3) / S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/ DATA (GB(10,12,IC),IC=1,3) / S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/ C C----- INTERVAL = 6 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 DATA (GA(11,11,IC),IC=1,3) / S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/ DATA (GB(11,11,IC),IC=1,3) / S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/ DATA (GA(11,12,IC),IC=1,3) / S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/ DATA (GB(11,12,IC),IC=1,3) / S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/ C C C C C C-- END WATER VAPOR C C C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ---------------------- C C C C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9 C C----- INTERVAL = 2 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 1,13,IC),IC=1,3) / S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/ DATA (GB( 1,13,IC),IC=1,3) / S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/ DATA (GA( 1,14,IC),IC=1,3) / S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/ DATA (GB( 1,14,IC),IC=1,3) / S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 2,13,IC),IC=1,3) / S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/ DATA (GB( 2,13,IC),IC=1,3) / S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/ DATA (GA( 2,14,IC),IC=1,3) / S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/ DATA (GB( 2,14,IC),IC=1,3) / S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 3,13,IC),IC=1,3) / S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/ DATA (GB( 3,13,IC),IC=1,3) / S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/ DATA (GA( 3,14,IC),IC=1,3) / S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/ DATA (GB( 3,14,IC),IC=1,3) / S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 4,13,IC),IC=1,3) / S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/ DATA (GB( 4,13,IC),IC=1,3) / S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/ DATA (GA( 4,14,IC),IC=1,3) / S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/ DATA (GB( 4,14,IC),IC=1,3) / S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 5,13,IC),IC=1,3) / S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/ DATA (GB( 5,13,IC),IC=1,3) / S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/ DATA (GA( 5,14,IC),IC=1,3) / S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/ DATA (GB( 5,14,IC),IC=1,3) / S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 6,13,IC),IC=1,3) / S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/ DATA (GB( 6,13,IC),IC=1,3) / S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/ DATA (GA( 6,14,IC),IC=1,3) / S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/ DATA (GB( 6,14,IC),IC=1,3) / S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 7,13,IC),IC=1,3) / S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/ DATA (GB( 7,13,IC),IC=1,3) / S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/ DATA (GA( 7,14,IC),IC=1,3) / S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/ DATA (GB( 7,14,IC),IC=1,3) / S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 8,13,IC),IC=1,3) / S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/ DATA (GB( 8,13,IC),IC=1,3) / S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/ DATA (GA( 8,14,IC),IC=1,3) / S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/ DATA (GB( 8,14,IC),IC=1,3) / S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA( 9,13,IC),IC=1,3) / S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/ DATA (GB( 9,13,IC),IC=1,3) / S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/ DATA (GA( 9,14,IC),IC=1,3) / S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/ DATA (GB( 9,14,IC),IC=1,3) / S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA(10,13,IC),IC=1,3) / S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/ DATA (GB(10,13,IC),IC=1,3) / S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/ DATA (GA(10,14,IC),IC=1,3) / S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/ DATA (GB(10,14,IC),IC=1,3) / S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/ C C----- INTERVAL = 2 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 DATA (GA(11,13,IC),IC=1,3) / S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/ DATA (GB(11,13,IC),IC=1,3) / S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/ DATA (GA(11,14,IC),IC=1,3) / S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/ DATA (GB(11,14,IC),IC=1,3) / S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/ C C C C C C C C C C C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1) C C C-- G = 0.0 C C C----- INTERVAL = 4 ----- T = 187.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 1,15,IC),IC=1,3) / S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/ DATA (GB( 1,15,IC),IC=1,3) / S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/ DATA (GA( 1,16,IC),IC=1,3) / S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/ DATA (GB( 1,16,IC),IC=1,3) / S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 200.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 2,15,IC),IC=1,3) / S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/ DATA (GB( 2,15,IC),IC=1,3) / S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/ DATA (GA( 2,16,IC),IC=1,3) / S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/ DATA (GB( 2,16,IC),IC=1,3) / S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 212.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 3,15,IC),IC=1,3) / S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/ DATA (GB( 3,15,IC),IC=1,3) / S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/ DATA (GA( 3,16,IC),IC=1,3) / S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/ DATA (GB( 3,16,IC),IC=1,3) / S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 225.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 4,15,IC),IC=1,3) / S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/ DATA (GB( 4,15,IC),IC=1,3) / S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/ DATA (GA( 4,16,IC),IC=1,3) / S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/ DATA (GB( 4,16,IC),IC=1,3) / S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 237.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 5,15,IC),IC=1,3) / S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/ DATA (GB( 5,15,IC),IC=1,3) / S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/ DATA (GA( 5,16,IC),IC=1,3) / S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/ DATA (GB( 5,16,IC),IC=1,3) / S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 250.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 6,15,IC),IC=1,3) / S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/ DATA (GB( 6,15,IC),IC=1,3) / S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/ DATA (GA( 6,16,IC),IC=1,3) / S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/ DATA (GB( 6,16,IC),IC=1,3) / S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 262.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 7,15,IC),IC=1,3) / S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/ DATA (GB( 7,15,IC),IC=1,3) / S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/ DATA (GA( 7,16,IC),IC=1,3) / S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/ DATA (GB( 7,16,IC),IC=1,3) / S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 275.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 8,15,IC),IC=1,3) / S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/ DATA (GB( 8,15,IC),IC=1,3) / S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/ DATA (GA( 8,16,IC),IC=1,3) / S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/ DATA (GB( 8,16,IC),IC=1,3) / S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 287.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA( 9,15,IC),IC=1,3) / S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/ DATA (GB( 9,15,IC),IC=1,3) / S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/ DATA (GA( 9,16,IC),IC=1,3) / S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/ DATA (GB( 9,16,IC),IC=1,3) / S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 300.0 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA(10,15,IC),IC=1,3) / S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/ DATA (GB(10,15,IC),IC=1,3) / S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/ DATA (GA(10,16,IC),IC=1,3) / S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/ DATA (GB(10,16,IC),IC=1,3) / S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/ C C----- INTERVAL = 4 ----- T = 312.5 C C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 DATA (GA(11,15,IC),IC=1,3) / S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/ DATA (GB(11,15,IC),IC=1,3) / S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/ DATA (GA(11,16,IC),IC=1,3) / S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/ DATA (GB(11,16,IC),IC=1,3) / S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/ C ------------------------------------------------------------------ DATA (( XP( J,K),J=1,6), K=1,6) / S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03, S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02, S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02, S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02, S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01, S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 / C C C* 1.0 PLANCK FUNCTIONS AND GRADIENTS C ------------------------------ C 100 CONTINUE C DO 102 JK = 1 , KFLEV+1 DO 101 JL = 1, KDLON PBINT(JL,JK) = 0. 101 CONTINUE 102 CONTINUE DO 103 JL = 1, KDLON PBSUIN(JL) = 0. 103 CONTINUE C DO 141 JNU=1,Ninter C C C* 1.1 LEVELS FROM SURFACE TO KFLEV C ---------------------------- C 110 CONTINUE C DO 112 JK = 1 , KFLEV DO 111 JL = 1, KDLON ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) S ))))) PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL) PB(JL,JNU,JK)= ZRES(JL) ZBLEV(JL,JK) = ZRES(JL) ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) S ))))) ZBLAY(JL,JK) = ZRES2(JL) 111 CONTINUE 112 CONTINUE C C C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE C --------------------------------- C 120 CONTINUE C DO 121 JL = 1, KDLON ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) S ))))) ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) S ))))) PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL) PB(JL,JNU,KFLEV+1)= ZRES(JL) ZBLEV(JL,KFLEV+1) = ZRES(JL) PBTOP(JL,JNU) = ZRES(JL) PBSUR(JL,JNU) = ZRES2(JL) PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL) 121 CONTINUE C C C* 1.3 GRADIENTS IN SUB-LAYERS C ----------------------- C 130 CONTINUE C DO 132 JK = 1 , KFLEV JK2 = 2 * JK JK1 = JK2 - 1 DO 131 JL = 1, KDLON PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK) PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK) 131 CONTINUE 132 CONTINUE C 141 CONTINUE C C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS C --------------------------------------------- C 200 CONTINUE C C 210 CONTINUE C DO 211 JL=1, KDLON ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) ) ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP IF (ZDSTOX.LT.0.5) THEN INDTO=IXTOX ELSE INDTO=IXTOX+1 END IF INDB(JL)=INDTO ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP IF (ZDSTX.LT.0.5) THEN INDT=IXTX ELSE INDT=IXTX+1 END IF INDS(JL)=INDT 211 CONTINUE C DO 214 JF=1,2 DO 213 JG=1, 8 DO 212 JL=1, KDLON INDSU=INDS(JL) PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF) PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF) INDTP=INDB(JL) PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF) PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF) 212 CONTINUE 213 CONTINUE 214 CONTINUE C 220 CONTINUE C DO 225 JK=1,KFLEV DO 221 JL=1, KDLON ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP IF (ZDSTX.LT.0.5) THEN INDT=IXTX ELSE INDT=IXTX+1 END IF INDB(JL)=INDT 221 CONTINUE C DO 224 JF=1,2 DO 223 JG=1, 8 DO 222 JL=1, KDLON INDT=INDB(JL) PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF) PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF) 222 CONTINUE 223 CONTINUE 224 CONTINUE 225 CONTINUE C C ------------------------------------------------------------------ C RETURN END SUBROUTINE LWV(KUAER,KTRAER, KLIM R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP S , PCNTRB,PCTS,PFLUC) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" include "YOMCST.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE C FLUXES OR RADIANCES C C METHOD. C ------- C C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN C CONTRIBUTIONS BY - THE NEARBY LAYERS C - THE DISTANT LAYERS C - THE BOUNDARY TERMS C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C----------------------------------------------------------------------- C C* ARGUMENTS: INTEGER KUAER,KTRAER, KLIM C REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS C REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES C----------------------------------------------------------------------- C LOCAL VARIABLES: REAL*8 ZADJD(KDLON,KFLEV+1) REAL*8 ZADJU(KDLON,KFLEV+1) REAL*8 ZDBDT(KDLON,Ninter,KFLEV) REAL*8 ZDISD(KDLON,KFLEV+1) REAL*8 ZDISU(KDLON,KFLEV+1) C INTEGER jk, jl C----------------------------------------------------------------------- C DO 112 JK=1,KFLEV+1 DO 111 JL=1, KDLON ZADJD(JL,JK)=0. ZADJU(JL,JK)=0. ZDISD(JL,JK)=0. ZDISU(JL,JK)=0. 111 CONTINUE 112 CONTINUE C DO 114 JK=1,KFLEV DO 113 JL=1, KDLON PCTS(JL,JK)=0. 113 CONTINUE 114 CONTINUE C C* CONTRIBUTION FROM ADJACENT LAYERS C CALL LWVN(KUAER,KTRAER R , PABCU,PDBSL,PGA,PGB S , ZADJD,ZADJU,PCNTRB,ZDBDT) C* CONTRIBUTION FROM DISTANT LAYERS C CALL LWVD(KUAER,KTRAER R , PABCU,ZDBDT,PGA,PGB S , PCNTRB,ZDISD,ZDISU) C C* EXCHANGE WITH THE BOUNDARIES C CALL LWVB(KUAER,KTRAER, KLIM R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP R , ZDISD,ZDISU,PEMIS,PPMB R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP S , PCTS,PFLUC) C C RETURN END SUBROUTINE LWVB(KUAER,KTRAER, KLIM R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP R , PDISD,PDISU,PEMIS,PPMB R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP S , PCTS,PFLUC) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" include "radopt.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL C INTEGRATION C C METHOD. C ------- C C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE C ATMOSPHERE C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96 C----------------------------------------------------------------------- C C* 0.1 ARGUMENTS C --------- C INTEGER KUAER,KTRAER, KLIM C REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS C REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM C C* LOCAL VARIABLES: C REAL*8 ZBGND(KDLON) REAL*8 ZFD(KDLON) REAL*8 ZFN10(KDLON) REAL*8 ZFU(KDLON) REAL*8 ZTT(KDLON,NTRA) REAL*8 ZTT1(KDLON,NTRA) REAL*8 ZTT2(KDLON,NTRA) REAL*8 ZUU(KDLON,NUA) REAL*8 ZCNSOL(KDLON) REAL*8 ZCNTOP(KDLON) C INTEGER jk, jl, ja INTEGER jstra, jstru INTEGER ind1, ind2, ind3, ind4, in, jlim REAL*8 zctstr C----------------------------------------------------------------------- C C* 1. INITIALIZATION C -------------- C 100 CONTINUE C C C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS C --------------------------------- C 120 CONTINUE C DO 122 JA=1,NTRA DO 121 JL=1, KDLON ZTT (JL,JA)=1.0 ZTT1(JL,JA)=1.0 ZTT2(JL,JA)=1.0 121 CONTINUE 122 CONTINUE C DO 124 JA=1,NUA DO 123 JL=1, KDLON ZUU(JL,JA)=1.0 123 CONTINUE 124 CONTINUE C C ------------------------------------------------------------------ C C* 2. VERTICAL INTEGRATION C -------------------- C 200 CONTINUE C IND1=0 IND3=0 IND4=1 IND2=1 C C C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE C ----------------------------------- C 230 CONTINUE C DO 235 JK = 1 , KFLEV IN=(JK-1)*NG1P1+1 C DO 232 JA=1,KUAER DO 231 JL=1, KDLON ZUU(JL,JA)=PABCU(JL,JA,IN) 231 CONTINUE 232 CONTINUE C C CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT) C DO 234 JL = 1, KDLON ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1) *ZTT(JL,10) 2 +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 3 +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 4 +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5 +PBTOP(JL,5)*ZTT(JL,3) *ZTT(JL,14) 6 +PBTOP(JL,6)*ZTT(JL,6) *ZTT(JL,15) ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) PFLUC(JL,2,JK)=ZFD(JL) 234 CONTINUE C 235 CONTINUE C JK = KFLEV+1 IN=(JK-1)*NG1P1+1 C DO 236 JL = 1, KDLON ZCNTOP(JL)= PBTOP(JL,1) 1 + PBTOP(JL,2) 2 + PBTOP(JL,3) 3 + PBTOP(JL,4) 4 + PBTOP(JL,5) 5 + PBTOP(JL,6) ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) PFLUC(JL,2,JK)=ZFD(JL) 236 CONTINUE C C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA C --------------------------------------- C 240 CONTINUE C C C* 2.4.1 INITIALIZATION C -------------- C 2410 CONTINUE C JLIM = KFLEV C IF (.NOT.LEVOIGT) THEN DO 2412 JK = KFLEV,1,-1 IF(PPMB(1,JK).LT.10.0) THEN JLIM=JK ENDIF 2412 CONTINUE ENDIF KLIM=JLIM C IF (.NOT.LEVOIGT) THEN DO 2414 JA=1,KTRAER DO 2413 JL=1, KDLON ZTT1(JL,JA)=1.0 2413 CONTINUE 2414 CONTINUE C C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA C ----------------------------- C 2420 CONTINUE C DO 2427 JSTRA = KFLEV,JLIM,-1 JSTRU=(JSTRA-1)*NG1P1+1 C DO 2423 JA=1,KUAER DO 2422 JL=1, KDLON ZUU(JL,JA)=PABCU(JL,JA,JSTRU) 2422 CONTINUE 2423 CONTINUE C C CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT) C DO 2424 JL = 1, KDLON ZCTSTR = 1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1)) 1 *(ZTT1(JL,1) *ZTT1(JL,10) 1 - ZTT (JL,1) *ZTT (JL,10)) 2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1)) 2 *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11) 2 - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11)) 3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1)) 3 *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12) 3 - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12)) 4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1)) 4 *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13) 4 - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13)) 5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1)) 5 *(ZTT1(JL,3) *ZTT1(JL,14) 5 - ZTT (JL,3) *ZTT (JL,14)) 6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1)) 6 *(ZTT1(JL,6) *ZTT1(JL,15) 6 - ZTT (JL,6) *ZTT (JL,15)) PCTS(JL,JSTRA)=ZCTSTR*0.5 2424 CONTINUE DO 2426 JA=1,KTRAER DO 2425 JL=1, KDLON ZTT1(JL,JA)=ZTT(JL,JA) 2425 CONTINUE 2426 CONTINUE 2427 CONTINUE ENDIF C Mise a zero de securite pour PCTS en cas de LEVOIGT IF(LEVOIGT)THEN DO 2429 JSTRA = 1,KFLEV DO 2428 JL = 1, KDLON PCTS(JL,JSTRA)=0. 2428 CONTINUE 2429 CONTINUE ENDIF C C C* 2.5 EXCHANGE WITH LOWER LIMIT C ------------------------- C 250 CONTINUE C DO 251 JL = 1, KDLON ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL)) S *PFLUC(JL,2,1)-PBINT(JL,1) 251 CONTINUE C JK = 1 IN=(JK-1)*NG1P1+1 C DO 252 JL = 1, KDLON ZCNSOL(JL)=PBSUR(JL,1) 1 +PBSUR(JL,2) 2 +PBSUR(JL,3) 3 +PBSUR(JL,4) 4 +PBSUR(JL,5) 5 +PBSUR(JL,6) ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) PFLUC(JL,1,JK)=ZFU(JL) 252 CONTINUE C DO 257 JK = 2 , KFLEV+1 IN=(JK-1)*NG1P1+1 C C DO 255 JA=1,KUAER DO 254 JL=1, KDLON ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN) 254 CONTINUE 255 CONTINUE C C CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT) C DO 256 JL = 1, KDLON ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1) *ZTT(JL,10) 2 +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 3 +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 4 +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5 +PBSUR(JL,5)*ZTT(JL,3) *ZTT(JL,14) 6 +PBSUR(JL,6)*ZTT(JL,6) *ZTT(JL,15) ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) PFLUC(JL,1,JK)=ZFU(JL) 256 CONTINUE C C 257 CONTINUE C C C C* 2.7 CLEAR-SKY FLUXES C ---------------- C 270 CONTINUE C IF (.NOT.LEVOIGT) THEN DO 271 JL = 1, KDLON ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM) 271 CONTINUE DO 273 JK = JLIM+1,KFLEV+1 DO 272 JL = 1, KDLON ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) PFLUC(JL,1,JK) = ZFN10(JL) PFLUC(JL,2,JK) = 0. 272 CONTINUE 273 CONTINUE ENDIF C C ------------------------------------------------------------------ C RETURN END SUBROUTINE LWVD(KUAER,KTRAER S , PABCU,PDBDT R , PGA,PGB S , PCNTRB,PDISD,PDISU) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS C C METHOD. C ------- C C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C----------------------------------------------------------------------- C* ARGUMENTS: C INTEGER KUAER,KTRAER C REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS C REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS C C* LOCAL VARIABLES: C REAL*8 ZGLAYD(KDLON) REAL*8 ZGLAYU(KDLON) REAL*8 ZTT(KDLON,NTRA) REAL*8 ZTT1(KDLON,NTRA) REAL*8 ZTT2(KDLON,NTRA) C INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2 INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2 INTEGER ind1, ind2, ind3, ind4, itt REAL*8 zww, zdzxdg, zdzxmg C C* 1. INITIALIZATION C -------------- C 100 CONTINUE C C* 1.1 INITIALIZE LAYER CONTRIBUTIONS C ------------------------------ C 110 CONTINUE C DO 112 JK = 1, KFLEV+1 DO 111 JL = 1, KDLON PDISD(JL,JK) = 0. PDISU(JL,JK) = 0. 111 CONTINUE 112 CONTINUE C C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS C --------------------------------- C 120 CONTINUE C C DO 122 JA = 1, NTRA DO 121 JL = 1, KDLON ZTT (JL,JA) = 1.0 ZTT1(JL,JA) = 1.0 ZTT2(JL,JA) = 1.0 121 CONTINUE 122 CONTINUE C C ------------------------------------------------------------------ C C* 2. VERTICAL INTEGRATION C -------------------- C 200 CONTINUE C IND1=0 IND3=0 IND4=1 IND2=1 C C C* 2.2 CONTRIBUTION FROM DISTANT LAYERS C --------------------------------- C 220 CONTINUE C C C* 2.2.1 DISTANT AND ABOVE LAYERS C ------------------------ C 2210 CONTINUE C C C C* 2.2.2 FIRST UPPER LEVEL C ----------------- C 2220 CONTINUE C DO 225 JK = 1 , KFLEV-1 IKP1=JK+1 IKN=(JK-1)*NG1P1+1 IKD1= JK *NG1P1+1 C CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK) 2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1) C C C C* 2.2.3 HIGHER UP C --------- C 2230 CONTINUE C ITT=1 DO 224 JKJ=IKP1,KFLEV IF(ITT.EQ.1) THEN ITT=2 ELSE ITT=1 ENDIF IKJP1=JKJ+1 IKD2= JKJ *NG1P1+1 C IF(ITT.EQ.1) THEN CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1) ELSE CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2) ENDIF C DO 2235 JA = 1, KTRAER DO 2234 JL = 1, KDLON ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 2234 CONTINUE 2235 CONTINUE C DO 2236 JL = 1, KDLON ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1) *ZTT(JL,10) S +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) S +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) S +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) S +PDBDT(JL,5,JKJ)*ZTT(JL,3) *ZTT(JL,14) S +PDBDT(JL,6,JKJ)*ZTT(JL,6) *ZTT(JL,15) ZGLAYD(JL)=ZWW ZDZXDG=ZGLAYD(JL) PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG PCNTRB(JL,JK,IKJP1)=ZDZXDG 2236 CONTINUE C C 224 CONTINUE 225 CONTINUE C C C* 2.2.4 DISTANT AND BELOW LAYERS C ------------------------ C 2240 CONTINUE C C C C* 2.2.5 FIRST LOWER LEVEL C ----------------- C 2250 CONTINUE C DO 228 JK=3,KFLEV+1 IKN=(JK-1)*NG1P1+1 IKM1=JK-1 IKJ=JK-2 IKU1= IKJ *NG1P1+1 C C CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ) 2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1) C C C C* 2.2.6 DOWN BELOW C ---------- C 2260 CONTINUE C ITT=1 DO 227 JLK=1,IKJ IF(ITT.EQ.1) THEN ITT=2 ELSE ITT=1 ENDIF IJKL=IKM1-JLK IKU2=(IJKL-1)*NG1P1+1 C C IF(ITT.EQ.1) THEN CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1) ELSE CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2) ENDIF C DO 2265 JA = 1, KTRAER DO 2264 JL = 1, KDLON ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 2264 CONTINUE 2265 CONTINUE C DO 2266 JL = 1, KDLON ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1) *ZTT(JL,10) S +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) S +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) S +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) S +PDBDT(JL,5,IJKL)*ZTT(JL,3) *ZTT(JL,14) S +PDBDT(JL,6,IJKL)*ZTT(JL,6) *ZTT(JL,15) ZGLAYU(JL)=ZWW ZDZXMG=ZGLAYU(JL) PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG PCNTRB(JL,JK,IJKL)=ZDZXMG 2266 CONTINUE C C 227 CONTINUE 228 CONTINUE C RETURN END SUBROUTINE LWVN(KUAER,KTRAER R , PABCU,PDBSL,PGA,PGB S , PADJD,PADJU,PCNTRB,PDBDT) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS C TO GIVE LONGWAVE FLUXES OR RADIANCES C C METHOD. C ------- C C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 89-07-14 C----------------------------------------------------------------------- C C* ARGUMENTS: C INTEGER KUAER,KTRAER C REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS C REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT C C* LOCAL ARRAYS: C REAL*8 ZGLAYD(KDLON) REAL*8 ZGLAYU(KDLON) REAL*8 ZTT(KDLON,NTRA) REAL*8 ZTT1(KDLON,NTRA) REAL*8 ZTT2(KDLON,NTRA) REAL*8 ZUU(KDLON,NUA) C INTEGER jk, jl, ja, im12, ind, inu, ixu, jg INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu REAL*8 zwtr c C* Data Block: c REAL*8 WG1(2) SAVE WG1 DATA (WG1(jk),jk=1,2) /1.0, 1.0/ C----------------------------------------------------------------------- C C* 1. INITIALIZATION C -------------- C 100 CONTINUE C C* 1.1 INITIALIZE LAYER CONTRIBUTIONS C ------------------------------ C 110 CONTINUE C DO 112 JK = 1 , KFLEV+1 DO 111 JL = 1, KDLON PADJD(JL,JK) = 0. PADJU(JL,JK) = 0. 111 CONTINUE 112 CONTINUE C C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS C --------------------------------- C 120 CONTINUE C DO 122 JA = 1 , NTRA DO 121 JL = 1, KDLON ZTT (JL,JA) = 1.0 ZTT1(JL,JA) = 1.0 ZTT2(JL,JA) = 1.0 121 CONTINUE 122 CONTINUE C DO 124 JA = 1 , NUA DO 123 JL = 1, KDLON ZUU(JL,JA) = 0. 123 CONTINUE 124 CONTINUE C C ------------------------------------------------------------------ C C* 2. VERTICAL INTEGRATION C -------------------- C 200 CONTINUE C C C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS C --------------------------------- C 210 CONTINUE C DO 215 JK = 1 , KFLEV C C* 2.1.1 DOWNWARD LAYERS C --------------- C 2110 CONTINUE C IM12 = 2 * (JK - 1) IND = (JK - 1) * NG1P1 + 1 IXD = IND INU = JK * NG1P1 + 1 IXU = IND C DO 2111 JL = 1, KDLON ZGLAYD(JL) = 0. ZGLAYU(JL) = 0. 2111 CONTINUE C DO 213 JG = 1 , NG1 IBS = IM12 + JG IDD = IXD + JG DO 2113 JA = 1 , KUAER DO 2112 JL = 1, KDLON ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD) 2112 CONTINUE 2113 CONTINUE C C CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) C DO 2114 JL = 1, KDLON ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG) 2114 CONTINUE C C* 2.1.2 DOWNWARD LAYERS C --------------- C 2120 CONTINUE C IMU = IXU + JG DO 2122 JA = 1 , KUAER DO 2121 JL = 1, KDLON ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU) 2121 CONTINUE 2122 CONTINUE C C CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) C DO 2123 JL = 1, KDLON ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG) 2123 CONTINUE C 213 CONTINUE C DO 214 JL = 1, KDLON PADJD(JL,JK) = ZGLAYD(JL) PCNTRB(JL,JK,JK+1) = ZGLAYD(JL) PADJU(JL,JK+1) = ZGLAYU(JL) PCNTRB(JL,JK+1,JK) = ZGLAYU(JL) PCNTRB(JL,JK ,JK) = 0.0 214 CONTINUE C 215 CONTINUE C DO 218 JK = 1 , KFLEV JK2 = 2 * JK JK1 = JK2 - 1 DO 217 JNU = 1 , Ninter DO 216 JL = 1, KDLON PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2) 216 CONTINUE 217 CONTINUE 218 CONTINUE C RETURN C END SUBROUTINE LWTT(PGA,PGB,PUU, PTT) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" C C----------------------------------------------------------------------- C PURPOSE. C -------- C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL C INTERVALS. C C METHOD. C ------- C C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 88-12-15 C C----------------------------------------------------------------------- REAL*8 O1H, O2H PARAMETER (O1H=2230.) PARAMETER (O2H=100.) REAL*8 RPIALF0 PARAMETER (RPIALF0=2.0) C C* ARGUMENTS: C REAL*8 PUU(KDLON,NUA) REAL*8 PTT(KDLON,NTRA) REAL*8 PGA(KDLON,8,2) REAL*8 PGB(KDLON,8,2) C C* LOCAL VARIABLES: C REAL*8 zz, zxd, zxn REAL*8 zpu, zpu10, zpu11, zpu12, zpu13 REAL*8 zeu, zeu10, zeu11, zeu12, zeu13 REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o REAL*8 zsqn21, zodn21, zsqh42, zodh42 REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12 REAL*8 zuu11, zuu12, za11, za12 INTEGER jl, ja C ------------------------------------------------------------------ C C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION C ----------------------------------------------- C 100 CONTINUE C C DO 130 JA = 1 , 8 DO 120 JL = 1, KDLON ZZ =SQRT(PUU(JL,JA)) c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1)) c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) ) c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1) ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) PTT(JL,JA)=ZXN /ZXD 120 CONTINUE 130 CONTINUE C C ------------------------------------------------------------------ C C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS C --------------------------------------------------- C 200 CONTINUE C DO 201 JL = 1, KDLON PTT(JL, 9) = PTT(JL, 8) C C- CONTINUUM ABSORPTION: E- AND P-TYPE C ZPU = 0.002 * PUU(JL,10) ZPU10 = 112. * ZPU ZPU11 = 6.25 * ZPU ZPU12 = 5.00 * ZPU ZPU13 = 80.0 * ZPU ZEU = PUU(JL,11) ZEU10 = 12. * ZEU ZEU11 = 6.25 * ZEU ZEU12 = 5.00 * ZEU ZEU13 = 80.0 * ZEU C C- OZONE ABSORPTION C ZX = PUU(JL,12) ZY = PUU(JL,13) ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. ZVXY = RPIALF0 * ZY / (2. * ZX) ZAERCN = PUU(JL,17) + ZEU12 + ZPU12 ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) C C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) C C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 C c NEXOTIC=1 c IF (NEXOTIC.EQ.1) THEN ZXCH4 = PUU(JL,19) ZYCH4 = PUU(JL,20) ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) ZODH41 = ZVXY * ZSQH41 C C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 C ZXN2O = PUU(JL,21) ZYN2O = PUU(JL,22) ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) ZODN21 = ZVXY * ZSQN21 C C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 C ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) ZODH42 = ZVXY * ZSQH42 C C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 C ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) ZODN22 = ZVXY * ZSQN22 C C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 C ZA11 = 2. * PUU(JL,23) * 4.404E+05 ZTTF11 = 1. - ZA11 * 0.003225 C C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 C ZA12 = 2. * PUU(JL,24) * 6.7435E+05 ZTTF12 = 1. - ZA12 * 0.003225 C ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10 ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21 PTT(JL,10) = EXP( - PUU(JL,14) ) PTT(JL,11) = EXP( ZUU11 ) PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 ) 201 CONTINUE C RETURN END SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT) IMPLICIT none include "dimensions.h" include "dimphy.h" include "raddim.h" include "raddimlw.h" C C ------------------------------------------------------------------ C PURPOSE. C -------- C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL C INTERVALS. C C METHOD. C ------- C C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. C C REFERENCE. C ---------- C C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS C C AUTHOR. C ------- C JEAN-JACQUES MORCRETTE *ECMWF* C C MODIFICATIONS. C -------------- C ORIGINAL : 88-12-15 C C----------------------------------------------------------------------- REAL*8 O1H, O2H PARAMETER (O1H=2230.) PARAMETER (O2H=100.) REAL*8 RPIALF0 PARAMETER (RPIALF0=2.0) C C* ARGUMENTS: C REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1 REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2 REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS C C* LOCAL VARIABLES: C INTEGER ja, jl REAL*8 zz, zxd, zxn REAL*8 zpu, zpu10, zpu11, zpu12, zpu13 REAL*8 zeu, zeu10, zeu11, zeu12, zeu13 REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2 REAL*8 zxch4, zych4, zsqh41, zodh41 REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42 REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12 REAL*8 zuu11, zuu12 C ------------------------------------------------------------------ C C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION C ----------------------------------------------- C 100 CONTINUE C C DO 130 JA = 1 , 8 DO 120 JL = 1, KDLON ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA)) ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) PTT(JL,JA)=ZXN /ZXD 120 CONTINUE 130 CONTINUE C C ------------------------------------------------------------------ C C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS C --------------------------------------------------- C 200 CONTINUE C DO 201 JL = 1, KDLON PTT(JL, 9) = PTT(JL, 8) C C- CONTINUUM ABSORPTION: E- AND P-TYPE C ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10)) ZPU10 = 112. * ZPU ZPU11 = 6.25 * ZPU ZPU12 = 5.00 * ZPU ZPU13 = 80.0 * ZPU ZEU = (PUU1(JL,11) - PUU2(JL,11)) ZEU10 = 12. * ZEU ZEU11 = 6.25 * ZEU ZEU12 = 5.00 * ZEU ZEU13 = 80.0 * ZEU C C- OZONE ABSORPTION C ZX = (PUU1(JL,12) - PUU2(JL,12)) ZY = (PUU1(JL,13) - PUU2(JL,13)) ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. ZVXY = RPIALF0 * ZY / (2. * ZX) ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12 ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) C C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) C C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 C ZXCH4 = (PUU1(JL,19) - PUU2(JL,19)) ZYCH4 = (PUU1(JL,20) - PUU2(JL,20)) ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) ZODH41 = ZVXY * ZSQH41 C C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 C ZXN2O = (PUU1(JL,21) - PUU2(JL,21)) ZYN2O = (PUU1(JL,22) - PUU2(JL,22)) ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) ZODN21 = ZVXY * ZSQN21 C C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 C ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) ZODH42 = ZVXY * ZSQH42 C C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 C ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) ZODN22 = ZVXY * ZSQN22 C C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 C ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05 ZTTF11 = 1. - ZA11 * 0.003225 C C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 C ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05 ZTTF12 = 1. - ZA12 * 0.003225 C ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10 ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 - S ZODH41 - ZODN21 PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) ) PTT(JL,11) = EXP( ZUU11 ) PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 ) 201 CONTINUE C RETURN END c============================================================== SUBROUTINE suphec C include "YOMCST.h" include "YOETHF.h" C ----------------------------------------------------------------- C C* 1. DEFINE FUNDAMENTAL CONSTANTS. C ----------------------------- C c sb WRITE(UNIT=6,FMT='(''0*** Constants of the ICM ***'')') RPI=2.*ASIN(1.) RCLUM=299792458. RHPLA=6.6260755E-34 RKBOL=1.380658E-23 RNAVO=6.0221367E+23 c sb WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')') c sb WRITE(UNIT=6,FMT='('' PI = '',E13.7,'' -'')')RPI c sb WRITE(UNIT=6,FMT='('' c = '',E13.7,''m s-1'')') c sb S RCLUM c sb WRITE(UNIT=6,FMT='('' h = '',E13.7,''J s'')') c sb S RHPLA c sb WRITE(UNIT=6,FMT='('' K = '',E13.7,''J K-1'')') c sb S RKBOL c sb WRITE(UNIT=6,FMT='('' N = '',E13.7,''mol-1'')') c sb S RNAVO C C ---------------------------------------------------------------- C C* 2. DEFINE ASTRONOMICAL CONSTANTS. C ------------------------------ C RDAY=86400. REA=149597870000. REPSM=0.409093 C RSIYEA=365.25*RDAY*2.*RPI/6.283076 RSIDAY=RDAY/(1.+RDAY/RSIYEA) ROMEGA=2.*RPI/RSIDAY c c exp1 R_ecc = 0.05 c exp1 R_peri = 102.04 c exp1 R_incl = 22.5 c exp1 print*, 'Parametres orbitaux modifies' c ref R_ecc = 0.016724 c ref R_peri = 102.04 c ref R_incl = 23.5 R_ecc = 0.016724 R_peri = 102.04 R_incl = 23.5 c c sb WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')') c sb WRITE(UNIT=6,FMT='('' day = '',E13.7,'' s'')')RDAY c sb WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA c sb WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM c sb WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA c sb WRITE(UNIT=6,FMT='('' sideral day = '',E13.7,'' s'')')RSIDAY c sb WRITE(UNIT=6,FMT='('' omega = '',E13.7,'' s-1'')') c sb S ROMEGA c sb write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc c sb write(unit=6,fmt='('' equinoxe = '',e13.7,''-'')')R_peri c sb write(unit=6,fmt='('' inclinaison = '',e13.7,''-'')')R_incl C C ------------------------------------------------------------------ C C* 3. DEFINE GEOIDE. C -------------- C RG=9.80665 RA=6371229. R1SA=SNGL(1.D0/DBLE(RA)) c sb WRITE(UNIT=6,FMT='('' *** Geoide ***'')') c sb WRITE(UNIT=6,FMT='('' Gravity = '',E13.7,'' m s-2'')') c sb S RG c sb WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA c sb WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA C C ----------------------------------------------------------------- C C* 4. DEFINE RADIATION CONSTANTS. C --------------------------- C c z.x.li RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3) rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15. RI0=1370. c sb WRITE(UNIT=6,FMT='('' *** Radiation ***'')') c sb WRITE(UNIT=6,FMT='('' Stefan-Bol. = '',E13.7,'' W m-2 K-4'' c sb S )') RSIGMA c sb WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')') c sb S RI0 C C ----------------------------------------------------------------- C C* 5. DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE. C ------------------------------------------ C R=RNAVO*RKBOL RMD=28.9644 RMV=18.0153 RD=1000.*R/RMD RV=1000.*R/RMV RCPD=3.5*RD RCVD=RCPD-RD RCPV=4. *RV RCVV=RCPV-RV RKAPPA=RD/RCPD RETV=RV/RD-1. c sb WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas ***'')') c sb WRITE(UNIT=6,FMT='('' Perfect gas = '',e13.7)') R c sb WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD c sb WRITE(UNIT=6,FMT='('' Vapour mass = '',e13.7)') RMV c sb WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD c sb WRITE(UNIT=6,FMT='('' Vapour cst. = '',e13.7)') RV c sb WRITE(UNIT=6,FMT='('' Cpd = '',e13.7)') RCPD c sb WRITE(UNIT=6,FMT='('' Cvd = '',e13.7)') RCVD c sb WRITE(UNIT=6,FMT='('' Cpv = '',e13.7)') RCPV c sb WRITE(UNIT=6,FMT='('' Cvv = '',e13.7)') RCVV c sb WRITE(UNIT=6,FMT='('' Rd/Cpd = '',e13.7)') RKAPPA c sb WRITE(UNIT=6,FMT='('' Rv/Rd-1 = '',e13.7)') RETV C C ---------------------------------------------------------------- C C* 6. DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE. C --------------------------------------------- C RCW=4218. c sb WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid ***'')') c sb WRITE(UNIT=6,FMT='('' Cw = '',E13.7)') RCW C C ---------------------------------------------------------------- C C* 7. DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE. C -------------------------------------------- C RCS=2106. c sb WRITE(UNIT=6,FMT='('' *** thermodynamic, solid ***'')') c sb WRITE(UNIT=6,FMT='('' Cs = '',E13.7)') RCS C C ---------------------------------------------------------------- C C* 8. DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE. C ---------------------------------------------------- C RTT=273.16 RLVTT=2.5008E+6 RLSTT=2.8345E+6 RLMLT=RLSTT-RLVTT RATM=100000. c sb WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans. ***'')') c sb WRITE(UNIT=6,FMT='('' Fusion point = '',E13.7)') RTT c sb WRITE(UNIT=6,FMT='('' RLvTt = '',E13.7)') RLVTT c sb WRITE(UNIT=6,FMT='('' RLsTt = '',E13.7)') RLSTT c sb WRITE(UNIT=6,FMT='('' RLMlt = '',E13.7)') RLMLT c sb WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM c sb WRITE(UNIT=6,FMT='('' Latent heat : '')') C C ---------------------------------------------------------------- C C* 9. SATURATED VAPOUR PRESSURE. C -------------------------- C RESTT=611.14 RGAMW=(RCW-RCPV)/RV RBETW=RLVTT/RV+RGAMW*RTT RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT) RGAMS=(RCS-RCPV)/RV RBETS=RLSTT/RV+RGAMS*RTT RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT) RGAMD=RGAMS-RGAMW RBETD=RBETS-RBETW RALPD=RALPS-RALPW C C ------------------------------------------------------------------ c c calculer les constantes pour les fonctions thermodynamiques c RVTMP2=RCPV/RCPD-1. RHOH2O=RATM/100. c sb WRITE(UNIT=6,FMT='('' RHOL = '',E13.7)') RHOH2O ! ajout sb R2ES=RESTT*RD/RV R3LES=17.269 R3IES=21.875 R4LES=35.86 R4IES=7.66 R5LES=R3LES*(RTT-R4LES) R5IES=R3IES*(RTT-R4IES) C RETURN END SUBROUTINE alboc(rjour,rlat,albedo) IMPLICIT none c====================================================================== c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD) c Date: le 16 mars 1995 c Objet: Calculer l'albedo sur l'ocean c Methode: Integrer numeriquement l'albedo pendant une journee c c Arguments; c rjour (in,R) : jour dans l'annee (a compter du 1 janvier) c rlat (in,R) : latitude en degre c albedo (out,R): albedo obtenu (de 0 a 1) c c Nov 1999: modification S. Bony: c use another formula for the dependance of the sfc ocean albedo c on the solar zenith angle (derived from ECHAM-3; the original c doesn't seem reasonable to me...). c====================================================================== include "dimensions.h" include "dimphy.h" include "YOMCST.h" c REAL fmagic ! un facteur magique pour regler l'albedo ccc PARAMETER (fmagic=0.7) PARAMETER (fmagic=1.0) INTEGER npts ! il controle la precision de l'integration PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes c REAL rlat(klon), rjour, albedo(klon) REAL zdist, zlonsun, zpi, zdeclin REAL rmu,alb, srmu, salb, fauxo, aa, bb INTEGER i, k c zpi = 4. * ATAN(1.) c c Calculer la longitude vraie de l'orbite terrestre: CALL orbite(rjour,zlonsun,zdist) c c Calculer la declinaison du soleil (qui varie entre + et - R_incl): zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0)) c DO 999 i=1,klon aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin) bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin) c c Midi local (angle du temps = 0.0): rmu = aa + bb * COS(0.0) rmu = MAX(0.0, rmu) c -- sb: ccc fauxo = (1.47-ACOS(rmu))/.15 ccc alb = 0.03+0.630/(1.+fauxo*fauxo) alb = 0.05/(rmu + 0.15) ! echam-3 formula alb = MIN(alb,0.15) ! echam-3 c sb -- srmu = rmu salb = alb * rmu c c Faire l'integration numerique de midi a minuit (le facteur 2 c prend en compte l'autre moitie de la journee): DO k = 1, npts rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi) rmu = MAX(0.0, rmu) c -- sb: ccc fauxo = (1.47-ACOS(rmu))/.15 ccc alb = 0.03+0.630/(1.+fauxo*fauxo) alb = 0.05 / (rmu+0.15) ! echam-3 alb = MIN(alb,0.15) ! echam-3 c sb -- srmu = srmu + rmu * 2.0 salb = salb + alb*rmu * 2.0 ENDDO IF (srmu .NE. 0.0) THEN albedo(i) = salb / srmu * fmagic ELSE ! nuit polaire (on peut prendre une valeur quelconque) albedo(i) = fmagic ENDIF 999 CONTINUE RETURN END c===================================================================== SUBROUTINE alboc_cd(rmu0,albedo) IMPLICIT none c====================================================================== c Auteur(s): Z.X. Li (LMD/CNRS) c date: 19940624 c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen c Formule due a Larson and Barkstrom (1977) Proc. of the symposium C on radiation in the atmosphere, 19-28 August 1976, science Press, C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume. c c Arguments c rmu0 (in): cosinus de l'angle solaire zenithal c albedo (out): albedo de surface de l'ocean c====================================================================== include "dimensions.h" include "dimphy.h" REAL rmu0(klon), albedo(klon) c REAL fauxo INTEGER i c DO i = 1, klon c -- sb: ccc fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15 ccc albedo(i) = 1.1*( .03 + .630/( 1. + fauxo*fauxo)) ccc albedo(i) = MAX(MIN(albedo(i),0.60),0.04) c -- sb: use echam-3 formula: albedo(i) = 0.05/(rmu0(i) + 0.15) albedo(i) = MIN(albedo(i),0.15) c sb -- ENDDO c RETURN END c======================================================================== SUBROUTINE albsno(veget, agesno, alb_neig) IMPLICIT none c include "dimensions.h" include "dimphy.h" INTEGER nvm PARAMETER (nvm=8) REAL veget(klon,nvm) REAL alb_neig(klon) REAL agesno(klon) c INTEGER i, nv c REAL init(nvm), decay(nvm), as SAVE init, decay DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./ DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./ c DO i = 1, klon alb_neig(i) = 0.0 ENDDO DO nv = 1, nvm DO i = 1, klon as = init(nv)+decay(nv)*EXP(-agesno(i)/5.) alb_neig(i) = alb_neig(i) + veget(i,nv)*as ENDDO ENDDO c RETURN END