*=*=*=*= SW2S.html =*=*=*=*
SUBROUTINE SW2S ( KDLON, KFLEV, KAER, KNU S , PAER,PAKI,PALBS,PCG,PCLDSW,PDSIG,POMEGA,PRMU,PSEC,PTAU S , PUD,PUM S , PFDOWN,PFUP ) IMPLICIT LOGICAL (L) C #include "dimensions.h" #include "dimphys.h" #include "dimradmars.h" C C**** *SW2* - SHORTWAVE RADIATION, 2ND SPECTRAL INTERVAL 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** INTERFACE. C ---------- C SUBROUTINE SW2S ( KDLON, KFLEV, KAER, KNU C S , PAER,PAKI,PALBS,PCG,PCLDSW,PDSIG,POMEGA,PRMU,PSEC,PTAU C S , PUD,PUM C S , PFDOWN,PFUP ) C C *SW2S* IS CALLED FROM *SW*. C C C IMPLICIT ARGUMENTS : C -------------------- C C ==== INPUTS === C ==== OUTPUTS === 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 EXTERNALS. C ---------- C C *SWR*, *DEDD*, *SWTT* 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 C C C C----------------------------------------------------------------------- C #include "yomcst.h" #include "yomrad.h" #include "yomaer.h" #include "yomlw.h" #include "yomsw.h" #include "yomrdu.h" C C----------------------------------------------------------------------- C C C* 0.1 ARGUMENTS C --------- C REAL PAER(NDLO2,KFLEV,5), PAKI(NDLO2,2), PALBS(NDLO2,2) S , PCG(NDLO2,2,KFLEV), PCLDSW(NDLO2,KFLEV), PDSIG(NDLO2,KFLEV) S , POMEGA(NDLO2,2,KFLEV), PRMU(NDLO2), PSEC(NDLO2) S , PTAU(NDLO2,2,KFLEV), PUD(NDLO2,3,KFLEV+1) S , PUM(NDLO2,KFLEV+1) C REAL PFDOWN(NDLO2,KFLEV+1),PFUP(NDLO2,KFLEV+1) C C ------------------------------------------------------------------ C C* 0.2 LOCAL ARRAYS C ------------ C REAL ZCGAZ(NDLON,NFLEV), ZG(NDLON), ZGG(NDLON) S , ZPIZAZ(NDLON,NFLEV), ZRAYL(NDLON), ZRAY1(NDLON,NFLEV+1) S , ZRAY2(NDLON,NFLEV+1), ZREF(NDLON), ZREFZ(NDLON,2,NFLEV+1) S , ZRE1(NDLON), ZRE2(NDLON), ZRJ(NDLON,6,NFLEV+1) S , ZRK(NDLON,6,NFLEV+1), ZRL(NDLON,8), ZRMUE(NDLON,NFLEV+1) S , ZRMUZ(NDLON), ZRNEB(NDLON), ZRUEF(NDLON,8), ZR1(NDLON) S , ZR2(NDLON), ZR21(NDLON), ZR22(NDLON), ZS(NDLON) S , ZTAUAZ(NDLON,NFLEV), ZTO1(NDLON), ZTR(NDLON,2,NFLEV+1) S , ZTRA1(NDLON,NFLEV+1), ZTRA2(NDLON,NFLEV+1) S , ZTR1(NDLON), ZTR2(NDLON), ZW(NDLON), ZW1(NDLON), ZW2(NDLON) 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) = CRAY(KNU,1) + ZRMUM1 * (CRAY(KNU,2) + ZRMUM1 S * (CRAY(KNU,3) + ZRMUM1 * (CRAY(KNU,4) + ZRMUM1 S * (CRAY(KNU,5) + ZRMUM1 * CRAY(KNU,6) )))) 111 CONTINUE C C C ------------------------------------------------------------------ C C* 2. CONTINUUM SCATTERING CALCULATIONS C --------------------------------- C 200 CONTINUE C CALL SWR ( KDLON, KFLEV, KAER, KNU S , PAER, PALBS, PCG, PCLDSW, PDSIG, POMEGA, ZRAYL, 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) = PALBS(JL,KNU) ZREFZ(JL,1,1) = PALBS(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 DO 322 JL = 1 , KDLON ZRNEB(JL) = PCLDSW(JL,JKM1) ZAA = PUD(JL,JABS,JKM1) 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 PTAU(JL,KNU,JKM1) = AMAX1( PTAU(JL,KNU,JKM1) , ZEPSCT ) ZW(JL)= POMEGA(JL,KNU,JKM1) ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL) S + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1) S + ZAA * 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 DEDD ( KDLON S , 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 KREF=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,KREF,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,KREF,JKL) ZRJ(JL,JN,JKL) = ZRE11 ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,KREF,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)= AMAX1( ZRJ(JL,JAJ,JK) , ZEELOG ) ZRK(JL,JAJ,JK)= AMAX1( 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)= AMAX1( ZRJ(JL,JAJ,JK) , ZEELOG ) ZRK(JL,JAJ,JK)= AMAX1( 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 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 ZW1(JL) = ALOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK)) S / PAKI(JL,JAJ) 4211 CONTINUE C C* 4.2.2 TRANSMISSION FUNCTION C --------------------- C 4220 CONTINUE C CALL SWTT ( KDLON, KNU, JAJ, ZW1, ZR1 ) C DO 4221 JL = 1 , KDLON ZRL(JL,JKKI) = ZR1(JL) ZRUEF(JL,JKKI) = ZW1(JL) ZW2(JL) = ALOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK)) S / PAKI(JL,JAJ) 4221 CONTINUE C CALL SWTT ( KDLON, KNU, JAJ, ZW2, ZR2 ) C DO 423 JL = 1 , KDLON ZRL(JL,JKKP4) = ZR2(JL) ZRUEF(JL,JKKP4) = ZW2(JL) 423 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. INTRODUCTION OF OZONE ABSORPTION C -------------------------------- C 500 CONTINUE C JABS=3 DO 504 JK = 1 , KFLEV+1 DO 501 JL = 1 , KDLON ZW1(JL) = PUD(JL,JABS,JK) 501 CONTINUE C CALL SWTT ( KDLON, KNU, JABS, ZW1, ZR1 ) C DO 502 JL = 1 , KDLON PFDOWN(JL,JK) = ZR1(JL) * PFDOWN(JL,JK) * sunfr(KNU) ZW2(JL) = PUM(JL,JK) 502 CONTINUE C CALL SWTT ( KDLON, KNU, JABS, ZW2, ZR2 ) C DO 503 JL = 1 , KDLON PFUP(JL,JK) = ZR2(JL) * PFUP(JL,JK) * sunfr(KNU) 503 CONTINUE 504 CONTINUE C C ------------------------------------------------------------------ C RETURN END