*=*=*=*= SWR.html =*=*=*=*
SUBROUTINE SWR ( KDLON, KFLEV, KAER, KNU S , PAER, PALBS, PCG, PCLDSW, PDSIG, POMEGA, PRAYL, PSEC, PTAU S , PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMUE S , PTAUAZ, PTRA1, PTRA2 ) IMPLICIT LOGICAL (L) C #include "dimensions.h" #include "dimphys.h" #include "dimradmars.h" C C**** *SWR* - CONTINUUM SCATTERING COMPUTATIONS C C PURPOSE. C -------- C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF C CONTINUUM SCATTERING C C** INTERFACE. C ---------- C SUBROUTINE SWR ( KDLON, KFLEV, KAER, KNU C S , PAER, PALBS, PCG, PCLDSW, PDSIG, POMEGA, PRAYL, PSEC, PTAU C S , PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMUE C S , PTAUAZ, PTRA1, PTRA2 ) C C *SWR* IS CALLED EITHER FROM *SW1S* C OR FROM *SW2S* C C IMPLICIT ARGUMENTS : C -------------------- C C ==== INPUTS === C ==== OUTPUTS === C C METHOD. C ------- C C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION) C C EXTERNALS. C ---------- C C *DEDD* 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 #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), PALBS(NDLO2,2), PCG(NDLO2,2,KFLEV) S , PCLDSW(NDLO2,KFLEV), PDSIG(NDLO2,KFLEV) S , POMEGA(NDLO2,2,KFLEV), PRAYL(NDLO2) S , PSEC(NDLO2), PTAU(NDLO2,2,KFLEV) C REAL PRAY1(NDLO2,KFLEV+1), PRAY2(NDLO2,KFLEV+1) S , PREFZ(NDLO2,2,KFLEV+1), PRJ(NDLO2,6,KFLEV+1) S , PRK(NDLO2,6,KFLEV+1), PRMUE(NDLO2,KFLEV+1) S , PCGAZ(NDLO2,KFLEV),PPIZAZ(NDLO2,KFLEV),PTAUAZ(NDLO2,KFLEV) S , PTRA1(NDLO2,KFLEV+1), PTRA2(NDLO2,KFLEV+1) C C ------------------------------------------------------------------ C C* 0.2 LOCAL ARRAYS C ------------ C REAL ZC1I(NDLON,NFLEV+1), ZGG(NDLON), ZREF(NDLON) S , ZRE1(NDLON), ZRE2(NDLON) S , ZRMUZ(NDLON), ZRNEB(NDLON), ZR21(NDLON), ZR22(NDLON) S , ZR23(NDLON), ZSS1(NDLON), ZTO1(NDLON), ZTR(NDLON,2,NFLEV+1) S , ZTR1(NDLON), ZTR2(NDLON), ZW(NDLON) C 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)*PIZA(KNU,JAE) PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE) S * TAUA(KNU,JAE)*PIZA(KNU,JAE)*CGA(KNU,JAE) 105 CONTINUE 106 CONTINUE C DO 107 JL = 1 , KDLON c!-*- c if ((JK.eq.25).and.(JL.eq.200)) then c print *,'sol 1',PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK) c & ,JL,JK c do JAE=1,5 c print *,'jae',jae,PAER(JL,JK,JAE),TAUA(KNU,JAE),PIZA(KNU,JAE) c & ,CGA(KNU,JAE) c enddo c endif c!-*- PCGAZ(JL,JK) = CVMGT( 0., PCGAZ(JL,JK) / PPIZAZ(JL,JK), S (KAER.EQ.0).or. S (PPIZAZ(JL,JK).EQ.0) ) PPIZAZ(JL,JK) = CVMGT( 1., PPIZAZ(JL,JK) / PTAUAZ(JL,JK), S (KAER.EQ.0).or. S (PTAUAZ(JL,JK).EQ.0) ) PTAUAZ(JL,JK) = CVMGT( 0., PTAUAZ(JL,JK), S (KAER.EQ.0) ) c!-*- c if ((JK.eq.25).and.(JL.eq.200)) then c print *,'sol 2',PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK) c & ,JL,JK c endif c!-*- 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) c!-*- c if ((JK.eq.25).and.(JL.eq.200)) then c print *,'sol 3',PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK) c & ,JL,JK c endif c!-*- 107 CONTINUE C IF (NIMP.LT.2) THEN print*,'SWR TAU G PI ' PRINT 9401,JK,PTAUAZ(JLIMPRAD,JK),PCGAZ(JLIMPRAD,JK) , ,PPIZAZ(JLIMPRAD,JK) END IF C 108 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. 201 CONTINUE C DO 203 JK = 1 , KFLEV 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) = PCLDSW(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) S + (1.0-PCLDSW(JL,JKL))*(1.0-ZR21(JL)) ZC1I(JL,JKL) = 1.0-(1.0-ZSS1(JL))*(1.0-ZC1I(JL,JKLP1)) 202 CONTINUE C IF (NIMP.LT.2) THEN print*,'SWR coeffs diff' PRINT 9401,JK,ZR21(JLIMPRAD),ZR22(JLIMPRAD),ZSS1(JLIMPRAD) , ,ZC1I(JLIMPRAD,JKL) END IF C 203 CONTINUE C 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) = PALBS(JL,KNU) PREFZ(JL,1,1) = PALBS(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)= PCLDSW(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 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 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 + 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) ZW(JL) = ZR21(JL) / ZTO1(JL) ZREF(JL) = PREFZ(JL,1,JKM1) ZRMUZ(JL) = PRMUE(JL,JK) 342 CONTINUE C CALL DEDD ( KDLON S , 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 if(nimp.le.4) then jl=jlimprad print*,'diags en sorties de dedd' print*,'ZGG,ZREF,ZRMUZ,ZTO1,ZW,ZRE1,ZRE2,ZTR1,ZTR2,ZRNEB' print*,ZGG(jl),ZREF(jl),ZRMUZ(jl),ZTO1(jl),ZW(jl) , ,ZRE1(JL),ZRE2(JL),ZTR1(JL),ZTR2(JL),ZRNEB(JL) endif 346 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 IF (NIMP.EQ.0) THEN print*,'coefs pour l inversion de la diffusion SWR' JL=JLIMPRAD DO 401 JK = 1 , KFLEV+1 PRINT 9401,JK,PRAY1(JL,JK),PTRA1(JL,JK) S ,PRAY2(JL,JK),PTRA2(JL,JK) S ,PREFZ(JL,1,JK),ZTR(JL,1,JK) S ,PREFZ(JL,2,JK),ZTR(JL,2,JK) 401 CONTINUE C DO 402 JK = 1 , KFLEV PRINT 9402,JK,PRMUE(JL,JK),PCGAZ(JL,JK) S ,PPIZAZ(JL,JK),PTAUAZ(JL,JK) 402 CONTINUE C DO 403 JK = 1 , KFLEV+1 PRINT 9403,JK,(PRJ(JL,JA,JK),PRK(JL,JA,JK),JA=1,2) 403 CONTINUE END IF C C ------------------------------------------------------------------ C RETURN 899 FORMAT(1X,' SWR LOOP ',I4,' EXECUTED') 9401 FORMAT (1X,I3,8E12.5) 9402 FORMAT (1X,I3,4E15.6) 9403 FORMAT (1X,I3,4E16.8) END