--- trunk/phylmd/Radlwsw/sw2s.f 2013/11/15 18:45:49 76 +++ trunk/phylmd/Radlwsw/sw2s.f90 2014/03/05 14:38:41 81 @@ -1,547 +1,505 @@ - SUBROUTINE SW2S ( KNU - S , PAER , flag_aer, tauae, pizae, cgae - S , PAKI, PALBD, PALBP, PCG , PCLD, PCLEAR, PCLDSW - S , PDSIG ,POMEGA,POZ , PRMU , PSEC , PTAU - S , PUD ,PWV , PQS - S , PFDOWN,PFUP ) - use dimens_m - use dimphy - use raddim - use radepsi - IMPLICIT none -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 -c-OB - double precision flag_aer - double precision tauae(kdlon,kflev,2) - double precision pizae(kdlon,kflev,2) - double precision cgae(kdlon,kflev,2) - DOUBLE PRECISION PAER(KDLON,KFLEV,5) - DOUBLE PRECISION PAKI(KDLON,2) - DOUBLE PRECISION PALBD(KDLON,2) - DOUBLE PRECISION PALBP(KDLON,2) - DOUBLE PRECISION PCG(KDLON,2,KFLEV) - DOUBLE PRECISION PCLD(KDLON,KFLEV) - DOUBLE PRECISION PCLDSW(KDLON,KFLEV) - DOUBLE PRECISION PCLEAR(KDLON) - DOUBLE PRECISION PDSIG(KDLON,KFLEV) - DOUBLE PRECISION POMEGA(KDLON,2,KFLEV) - DOUBLE PRECISION POZ(KDLON,KFLEV) - DOUBLE PRECISION PQS(KDLON,KFLEV) - DOUBLE PRECISION PRMU(KDLON) - DOUBLE PRECISION PSEC(KDLON) - DOUBLE PRECISION PTAU(KDLON,2,KFLEV) - DOUBLE PRECISION PUD(KDLON,5,KFLEV+1) - DOUBLE PRECISION PWV(KDLON,KFLEV) -C - DOUBLE PRECISION PFDOWN(KDLON,KFLEV+1) - DOUBLE PRECISION PFUP(KDLON,KFLEV+1) -C -C* LOCAL VARIABLES: -C - INTEGER IIND2(2), IIND3(3) - DOUBLE PRECISION ZCGAZ(KDLON,KFLEV) - DOUBLE PRECISION ZFD(KDLON,KFLEV+1) - DOUBLE PRECISION ZFU(KDLON,KFLEV+1) - DOUBLE PRECISION ZG(KDLON) - DOUBLE PRECISION ZGG(KDLON) - DOUBLE PRECISION ZPIZAZ(KDLON,KFLEV) - DOUBLE PRECISION ZRAYL(KDLON) - DOUBLE PRECISION ZRAY1(KDLON,KFLEV+1) - DOUBLE PRECISION ZRAY2(KDLON,KFLEV+1) - DOUBLE PRECISION ZREF(KDLON) - DOUBLE PRECISION ZREFZ(KDLON,2,KFLEV+1) - DOUBLE PRECISION ZRE1(KDLON) - DOUBLE PRECISION ZRE2(KDLON) - DOUBLE PRECISION ZRJ(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRJ0(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRK(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRK0(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRL(KDLON,8) - DOUBLE PRECISION ZRMUE(KDLON,KFLEV+1) - DOUBLE PRECISION ZRMU0(KDLON,KFLEV+1) - DOUBLE PRECISION ZRMUZ(KDLON) - DOUBLE PRECISION ZRNEB(KDLON) - DOUBLE PRECISION ZRUEF(KDLON,8) - DOUBLE PRECISION ZR1(KDLON) - DOUBLE PRECISION ZR2(KDLON,2) - DOUBLE PRECISION ZR3(KDLON,3) - DOUBLE PRECISION ZR4(KDLON) - DOUBLE PRECISION ZR21(KDLON) - DOUBLE PRECISION ZR22(KDLON) - DOUBLE PRECISION ZS(KDLON) - DOUBLE PRECISION ZTAUAZ(KDLON,KFLEV) - DOUBLE PRECISION ZTO1(KDLON) - DOUBLE PRECISION ZTR(KDLON,2,KFLEV+1) - DOUBLE PRECISION ZTRA1(KDLON,KFLEV+1) - DOUBLE PRECISION ZTRA2(KDLON,KFLEV+1) - DOUBLE PRECISION ZTR1(KDLON) - DOUBLE PRECISION ZTR2(KDLON) - DOUBLE PRECISION ZW(KDLON) - DOUBLE PRECISION ZW1(KDLON) - DOUBLE PRECISION ZW2(KDLON,2) - DOUBLE PRECISION ZW3(KDLON,3) - DOUBLE PRECISION ZW4(KDLON) - DOUBLE PRECISION ZW5(KDLON) -C - INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 - INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs - DOUBLE PRECISION ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11 -C -C* Prescribed Data: -C - DOUBLE PRECISION RSUN(2) - SAVE RSUN - DOUBLE PRECISION 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 , flag_aer, tauae, pizae, cgae - S , 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 sw2s(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, palbp, & + pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, & + pwv, pqs, pfdown, pfup) + USE dimens_m + USE dimphy + USE raddim + USE radepsi + IMPLICIT NONE + + ! ------------------------------------------------------------------ + ! PURPOSE. + ! -------- + + ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE + ! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980). + + ! METHOD. + ! ------- + + ! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO + ! CONTINUUM SCATTERING + ! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR + ! A GREY MOLECULAR ABSORPTION + ! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS + ! OF ABSORBERS + ! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS + ! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION + + ! REFERENCE. + ! ---------- + + ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT + ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) + + ! AUTHOR. + ! ------- + ! JEAN-JACQUES MORCRETTE *ECMWF* + + ! MODIFICATIONS. + ! -------------- + ! ORIGINAL : 89-07-14 + ! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO + ! ------------------------------------------------------------------ + ! * ARGUMENTS: + + INTEGER knu + ! -OB + DOUBLE PRECISION flag_aer + DOUBLE PRECISION tauae(kdlon, kflev, 2) + DOUBLE PRECISION pizae(kdlon, kflev, 2) + DOUBLE PRECISION cgae(kdlon, kflev, 2) + DOUBLE PRECISION paer(kdlon, kflev, 5) + DOUBLE PRECISION paki(kdlon, 2) + DOUBLE PRECISION palbd(kdlon, 2) + DOUBLE PRECISION palbp(kdlon, 2) + DOUBLE PRECISION pcg(kdlon, 2, kflev) + DOUBLE PRECISION pcld(kdlon, kflev) + DOUBLE PRECISION pcldsw(kdlon, kflev) + DOUBLE PRECISION pclear(kdlon) + DOUBLE PRECISION pdsig(kdlon, kflev) + DOUBLE PRECISION pomega(kdlon, 2, kflev) + DOUBLE PRECISION poz(kdlon, kflev) + DOUBLE PRECISION pqs(kdlon, kflev) + DOUBLE PRECISION prmu(kdlon) + DOUBLE PRECISION psec(kdlon) + DOUBLE PRECISION ptau(kdlon, 2, kflev) + DOUBLE PRECISION pud(kdlon, 5, kflev+1) + DOUBLE PRECISION pwv(kdlon, kflev) + + DOUBLE PRECISION pfdown(kdlon, kflev+1) + DOUBLE PRECISION pfup(kdlon, kflev+1) + + ! * LOCAL VARIABLES: + + INTEGER iind2(2), iind3(3) + DOUBLE PRECISION zcgaz(kdlon, kflev) + DOUBLE PRECISION zfd(kdlon, kflev+1) + DOUBLE PRECISION zfu(kdlon, kflev+1) + DOUBLE PRECISION zg(kdlon) + DOUBLE PRECISION zgg(kdlon) + DOUBLE PRECISION zpizaz(kdlon, kflev) + DOUBLE PRECISION zrayl(kdlon) + DOUBLE PRECISION zray1(kdlon, kflev+1) + DOUBLE PRECISION zray2(kdlon, kflev+1) + DOUBLE PRECISION zref(kdlon) + DOUBLE PRECISION zrefz(kdlon, 2, kflev+1) + DOUBLE PRECISION zre1(kdlon) + DOUBLE PRECISION zre2(kdlon) + DOUBLE PRECISION zrj(kdlon, 6, kflev+1) + DOUBLE PRECISION zrj0(kdlon, 6, kflev+1) + DOUBLE PRECISION zrk(kdlon, 6, kflev+1) + DOUBLE PRECISION zrk0(kdlon, 6, kflev+1) + DOUBLE PRECISION zrl(kdlon, 8) + DOUBLE PRECISION zrmue(kdlon, kflev+1) + DOUBLE PRECISION zrmu0(kdlon, kflev+1) + DOUBLE PRECISION zrmuz(kdlon) + DOUBLE PRECISION zrneb(kdlon) + DOUBLE PRECISION zruef(kdlon, 8) + DOUBLE PRECISION zr1(kdlon) + DOUBLE PRECISION zr2(kdlon, 2) + DOUBLE PRECISION zr3(kdlon, 3) + DOUBLE PRECISION zr4(kdlon) + DOUBLE PRECISION zr21(kdlon) + DOUBLE PRECISION zr22(kdlon) + DOUBLE PRECISION zs(kdlon) + DOUBLE PRECISION ztauaz(kdlon, kflev) + DOUBLE PRECISION zto1(kdlon) + DOUBLE PRECISION ztr(kdlon, 2, kflev+1) + DOUBLE PRECISION ztra1(kdlon, kflev+1) + DOUBLE PRECISION ztra2(kdlon, kflev+1) + DOUBLE PRECISION ztr1(kdlon) + DOUBLE PRECISION ztr2(kdlon) + DOUBLE PRECISION zw(kdlon) + DOUBLE PRECISION zw1(kdlon) + DOUBLE PRECISION zw2(kdlon, 2) + DOUBLE PRECISION zw3(kdlon, 3) + DOUBLE PRECISION zw4(kdlon) + DOUBLE PRECISION zw5(kdlon) + + INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 + INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs + DOUBLE PRECISION zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11 + + ! * Prescribed Data: + + DOUBLE PRECISION rsun(2) + SAVE rsun + DOUBLE PRECISION rray(2, 6) + SAVE rray + DATA rsun(1)/0.441676/ + DATA rsun(2)/0.558324/ + DATA (rray(1,k), k=1, 6)/.428937E-01, .890743E+00, -.288555E+01, & + .522744E+01, -.469173E+01, .161645E+01/ + DATA (rray(2,k), k=1, 6)/.697200E-02, .173297E-01, -.850903E-01, & + .248261E+00, -.302031E+00, .129662E+00/ + + ! ------------------------------------------------------------------ + + ! * 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON) + ! ------------------------------------------- + + + + ! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING + ! ----------------------------------------- + + + DO jl = 1, kdlon + zrmum1 = 1. - prmu(jl) + zrayl(jl) = rray(knu, 1) + zrmum1*(rray(knu,2)+zrmum1*(rray(knu, & + 3)+zrmum1*(rray(knu,4)+zrmum1*(rray(knu,5)+zrmum1*rray(knu,6))))) + END DO + + + ! ------------------------------------------------------------------ + + ! * 2. CONTINUUM SCATTERING CALCULATIONS + ! --------------------------------- + + + ! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN + ! -------------------------------- + + + CALL swclr(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, & + psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, & + ztra1, ztra2) + + + ! * 2.2 CLOUDY FRACTION OF THE COLUMN + ! ----------------------------- + + + CALL swr(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, zcgaz, & + zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2) + + + ! ------------------------------------------------------------------ + + ! * 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION + ! ------------------------------------------------------ + + + jn = 2 + + DO jabs = 1, 2 + + + ! * 3.1 SURFACE CONDITIONS + ! ------------------ + + + DO jl = 1, kdlon + zrefz(jl, 2, 1) = palbd(jl, knu) + zrefz(jl, 1, 1) = palbd(jl, knu) + END DO + + + ! * 3.2 INTRODUCING CLOUD EFFECTS + ! ------------------------- + + + DO jk = 2, kflev + 1 + jkm1 = jk - 1 + ikl = kflev + 1 - jkm1 + DO jl = 1, kdlon + zrneb(jl) = pcld(jl, jkm1) + IF (jabs==1 .AND. zrneb(jl)>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. + + zw(jl) = pomega(jl, knu, jkm1) + zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, & + jkm1) + 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) + (1.-zr22(jl))*zcgaz(jl, jkm1) + zw(jl) = zr21(jl)/zto1(jl) + zref(jl) = zrefz(jl, 1, jkm1) + zrmuz(jl) = zrmue(jl, jk) + END DO + + CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2) + + DO jl = 1, kdlon + + zrefz(jl, 2, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,2,jkm1)* & + ztra1(jl,jkm1)*ztra2(jl,jkm1))*zg(jl)*zs(jl) + zrneb(jl)*zre1(jl) + + ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + (ztra1(jl,jkm1))*zg(jl)*(1.- & + zrneb(jl)) + + zrefz(jl, 1, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,1,jkm1)* & + ztra1(jl,jkm1)*ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)*zrefz(jl,1, & + jkm1)))*zg(jl)*zs(jl) + zrneb(jl)*zre2(jl) + + ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, & + jkm1)*zrefz(jl,1,jkm1)))*zg(jl)*(1.-zrneb(jl)) + + END DO + END DO + + ! * 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL + ! ------------------------------------------------- + + + DO jref = 1, 2 + + jn = jn + 1 + + DO jl = 1, kdlon + zrj(jl, jn, kflev+1) = 1. + zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1) + END DO + + DO jk = 1, kflev + jkl = kflev + 1 - jk + jklp1 = jkl + 1 + DO 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) + END DO + END DO + END DO + END DO + + + ! ------------------------------------------------------------------ + + ! * 4. INVERT GREY AND CONTINUUM FLUXES + ! -------------------------------- + + + + ! * 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES + ! --------------------------------------------- + + + DO jk = 1, kflev + 1 + DO jaj = 1, 5, 2 + jajp = jaj + 1 + DO 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) + END DO + END DO + END DO + + DO jk = 1, kflev + 1 + DO jaj = 2, 6, 2 + DO jl = 1, kdlon + zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog) + zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog) + END DO + END DO + END DO + + ! * 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE + ! --------------------------------------------- + + + DO jk = 1, kflev + 1 + jkki = 1 + DO jaj = 1, 2 + iind2(1) = jaj + iind2(2) = jaj + DO jn = 1, 2 + jn2j = jn + 2*jaj + jkkp4 = jkki + 4 + + ! * 4.2.1 EFFECTIVE ABSORBER AMOUNTS + ! -------------------------- + + + DO jl = 1, kdlon + zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj) + zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj) + END DO + + ! * 4.2.2 TRANSMISSION FUNCTION + ! --------------------- + + + CALL swtt1(knu, 2, iind2, zw2, zr2) + + DO 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) + END DO + + jkki = jkki + 1 + END DO + END DO + + ! * 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION + ! ------------------------------------------------------ + + + DO jl = 1, kdlon + pfdown(jl, jk) = zrj(jl, 1, jk)*zrl(jl, 1)*zrl(jl, 3) + & + zrj(jl, 2, jk)*zrl(jl, 2)*zrl(jl, 4) + pfup(jl, jk) = zrk(jl, 1, jk)*zrl(jl, 5)*zrl(jl, 7) + & + zrk(jl, 2, jk)*zrl(jl, 6)*zrl(jl, 8) + END DO + END DO + + + ! ------------------------------------------------------------------ + + ! * 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES + ! ---------------------------------------- + + + + ! * 5.1 DOWNWARD FLUXES + ! --------------- + + + jaj = 2 + iind3(1) = 1 + iind3(2) = 2 + iind3(3) = 3 + + DO 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) + END DO + DO jk = 1, kflev + ikl = kflev + 1 - jk + DO 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) + END DO + + CALL swtt1(knu, 3, iind3, zw3, zr3) + + DO jl = 1, kdlon + ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + zfd(jl, ikl) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* & + zrj0(jl, jaj, ikl) + END DO + END DO + + + ! * 5.2 UPWARD FLUXES + ! ------------- + + + DO jl = 1, kdlon + zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu) + END DO + + DO jk = 2, kflev + 1 + ikm1 = jk - 1 + DO 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 + END DO + + CALL swtt1(knu, 3, iind3, zw3, zr3) + + DO jl = 1, kdlon + ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + zfu(jl, jk) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* & + zrk0(jl, jaj, jk) + END DO + END DO + + + ! ------------------------------------------------------------------ + + ! * 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION + ! -------------------------------------------------- + + iabs = 3 + + ! * 6.1 DOWNWARD FLUXES + ! --------------- + + DO 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)+pclear(jl)*zfd( & + jl,kflev+1))*rsun(knu) + END DO + + DO jk = 1, kflev + ikl = kflev + 1 - jk + DO 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) + ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + END DO + + CALL swtt(knu, iabs, zw1, zr1) + + DO jl = 1, kdlon + pfdown(jl, ikl) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfdown(jl,ikl)+ & + pclear(jl)*zfd(jl,ikl))*rsun(knu) + END DO + END DO + + + ! * 6.2 UPWARD FLUXES + ! ------------- + + DO jl = 1, kdlon + pfup(jl, 1) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,1)+pclear(jl)*zfu( & + jl,1))*rsun(knu) + END DO + + DO jk = 2, kflev + 1 + ikm1 = jk - 1 + DO 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 + ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + END DO + + CALL swtt(knu, iabs, zw1, zr1) + + DO jl = 1, kdlon + pfup(jl, jk) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,jk)+pclear(jl)* & + zfu(jl,jk))*rsun(knu) + END DO + END DO + + ! ------------------------------------------------------------------ + + RETURN +END SUBROUTINE sw2s