! IM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, SUBROUTINE sw_lmdar4(psct, prmu0, pfrac, ppmb, pdp, ppsol, palbd, palbp, & ptave, pwv, pqs, pozon, paer, pcldsw, ptau, pomega, pcg, pheat, pheat0, & palbpla, ptopsw, psolsw, ptopsw0, psolsw0, zfsup, zfsdn, zfsup0, zfsdn0, & tauae, pizae, cgae, ptaua, pomegaa, ptopswad, psolswad, ptopswai, & psolswai, ok_ade, ok_aie) USE dimphy USE print_control_mod, ONLY: lunout IMPLICIT NONE include "YOMCST.h" ! ------------------------------------------------------------------ ! PURPOSE. ! -------- ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). ! METHOD. ! ------- ! 1. COMPUTES ABSORBER AMOUNTS (SWU) ! 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) ! 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) ! 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 ! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo ! 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER) ! ------------------------------------------------------------------ ! * ARGUMENTS: REAL (KIND=8) psct ! constante solaire (valeur conseillee: 1370) ! IM ctes ds clesphys.h REAL(KIND=8) RCO2 ! concentration CO2 (IPCC: ! 353.E-06*44.011/28.97) include "clesphys.h" REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (PA) REAL (KIND=8) pdp(kdlon, kflev) ! LAYER THICKNESS (PA) REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB) REAL (KIND=8) prmu0(kdlon) ! COSINE OF ZENITHAL ANGLE REAL (KIND=8) pfrac(kdlon) ! fraction de la journee REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K) REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (KG/KG) REAL (KIND=8) pqs(kdlon, kflev) ! SATURATED WATER VAPOUR (KG/KG) REAL (KIND=8) pozon(kdlon, kflev) ! OZONE CONCENTRATION (KG/KG) REAL (KIND=8) paer(kdlon, kflev, 5) ! AEROSOLS' OPTICAL THICKNESS REAL (KIND=8) palbd(kdlon, 2) ! albedo du sol (lumiere diffuse) REAL (KIND=8) palbp(kdlon, 2) ! albedo du sol (lumiere parallele) REAL (KIND=8) pcldsw(kdlon, kflev) ! CLOUD FRACTION REAL (KIND=8) ptau(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS REAL (KIND=8) pcg(kdlon, 2, kflev) ! ASYMETRY FACTOR REAL (KIND=8) pomega(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO REAL (KIND=8) pheat(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY) REAL (KIND=8) pheat0(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY) clear-sky REAL (KIND=8) palbpla(kdlon) ! PLANETARY ALBEDO REAL (KIND=8) ptopsw(kdlon) ! SHORTWAVE FLUX AT T.O.A. REAL (KIND=8) psolsw(kdlon) ! SHORTWAVE FLUX AT SURFACE REAL (KIND=8) ptopsw0(kdlon) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) REAL (KIND=8) psolsw0(kdlon) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) ! * LOCAL VARIABLES: REAL, PARAMETER :: dobson_u = 2.1415E-05 ! Dobson unit, in kg m-2 REAL (KIND=8) zoz(kdlon, kflev) ! column-density of ozone in layer, in kilo-Dobsons REAL (KIND=8) zaki(kdlon, 2) REAL (KIND=8) zcld(kdlon, kflev) REAL (KIND=8) zclear(kdlon) REAL (KIND=8) zdsig(kdlon, kflev) REAL (KIND=8) zfact(kdlon) REAL (KIND=8) zfd(kdlon, kflev+1) REAL (KIND=8) zfdown(kdlon, kflev+1) REAL (KIND=8) zfu(kdlon, kflev+1) REAL (KIND=8) zfup(kdlon, kflev+1) REAL (KIND=8) zrmu(kdlon) REAL (KIND=8) zsec(kdlon) REAL (KIND=8) zud(kdlon, 5, kflev+1) REAL (KIND=8) zcldsw0(kdlon, kflev) REAL (KIND=8) zfsup(kdlon, kflev+1) REAL (KIND=8) zfsdn(kdlon, kflev+1) REAL (KIND=8) zfsup0(kdlon, kflev+1) REAL (KIND=8) zfsdn0(kdlon, kflev+1) INTEGER inu, jl, jk, i, k, kpl1 INTEGER swpas ! Every swpas steps, sw is calculated PARAMETER (swpas=1) INTEGER itapsw LOGICAL appel1er DATA itapsw/0/ DATA appel1er/.TRUE./ SAVE itapsw, appel1er !$OMP THREADPRIVATE(appel1er) !$OMP THREADPRIVATE(itapsw) ! jq-Introduced for aerosol forcings REAL (KIND=8) flag_aer LOGICAL ok_ade, ok_aie ! use aerosol forcings or not? REAL (KIND=8) tauae(kdlon, kflev, 2) ! aerosol optical properties REAL (KIND=8) pizae(kdlon, kflev, 2) ! (see aeropt.F) REAL (KIND=8) cgae(kdlon, kflev, 2) ! -"- REAL (KIND=8) ptaua(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS (pre-industrial value) REAL (KIND=8) pomegaa(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO REAL (KIND=8) ptopswad(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) REAL (KIND=8) psolswad(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) REAL (KIND=8) ptopswai(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) REAL (KIND=8) psolswai(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) ! jq - Fluxes including aerosol effects REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupad(:, :) !$OMP THREADPRIVATE(ZFSUPAD) REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnad(:, :) !$OMP THREADPRIVATE(ZFSDNAD) REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupai(:, :) !$OMP THREADPRIVATE(ZFSUPAI) REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnai(:, :) !$OMP THREADPRIVATE(ZFSDNAI) LOGICAL initialized ! ym SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes ! rv SAVE flag_aer !$OMP THREADPRIVATE(flag_aer) DATA initialized/.FALSE./ SAVE initialized !$OMP THREADPRIVATE(initialized) ! jq-end REAL tmp_ IF (.NOT. initialized) THEN flag_aer = 0. initialized = .TRUE. ALLOCATE (zfsupad(kdlon,kflev+1)) ALLOCATE (zfsdnad(kdlon,kflev+1)) ALLOCATE (zfsupai(kdlon,kflev+1)) ALLOCATE (zfsdnai(kdlon,kflev+1)) zfsupad(:, :) = 0. zfsdnad(:, :) = 0. zfsupai(:, :) = 0. zfsdnai(:, :) = 0. END IF IF (appel1er) THEN WRITE (lunout, *) 'SW calling frequency : ', swpas WRITE (lunout, *) ' In general, it should be 1' appel1er = .FALSE. END IF ! ------------------------------------------------------------------ IF (mod(itapsw,swpas)==0) THEN tmp_ = 1./(dobson_u*1E3*rg) ! cdir collapse DO jk = 1, kflev DO jl = 1, kdlon zcldsw0(jl, jk) = 0.0 zoz(jl, jk) = pozon(jl, jk)*tmp_*pdp(jl, jk) END DO END DO ! clear-sky: ! IM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL, CALL swu_lmdar4(psct, zcldsw0, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) inu = 1 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, & zfd, zfu) inu = 2 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & palbp, pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, & ptau, zud, pwv, pqs, 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) END DO END DO flag_aer = 0.0 CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) inu = 1 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, & zfd, zfu) inu = 2 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, & zud, pwv, pqs, zfdown, zfup) ! cloudy-sky: 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) END DO END DO IF (ok_ade) THEN ! cloudy-sky + aerosol dir OB flag_aer = 1.0 CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) inu = 1 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, & zfd, zfu) inu = 2 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, & ptau, zud, pwv, pqs, zfdown, zfup) DO jk = 1, kflev + 1 DO jl = 1, kdlon zfsupad(jl, jk) = zfsup(jl, jk) zfsdnad(jl, jk) = zfsdn(jl, jk) zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl) zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl) END DO END DO END IF ! ok_ade IF (ok_aie) THEN ! jq cloudy-sky + aerosol direct + aerosol indirect flag_aer = 1.0 CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) inu = 1 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, ptaua, & zud, zfd, zfu) inu = 2 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & palbp, pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, & ptaua, zud, pwv, pqs, zfdown, zfup) DO jk = 1, kflev + 1 DO jl = 1, kdlon zfsupai(jl, jk) = zfsup(jl, jk) zfsdnai(jl, jk) = zfsdn(jl, jk) zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl) zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl) END DO END DO END IF ! ok_aie ! jq -end itapsw = 0 END IF itapsw = itapsw + 1 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) END DO END DO DO i = 1, kdlon palbpla(i) = zfsup(i, kflev+1)/(zfsdn(i,kflev+1)+1.0E-20) psolsw(i) = zfsdn(i, 1) - zfsup(i, 1) ptopsw(i) = zfsdn(i, kflev+1) - zfsup(i, kflev+1) psolsw0(i) = zfsdn0(i, 1) - zfsup0(i, 1) ptopsw0(i) = zfsdn0(i, kflev+1) - zfsup0(i, kflev+1) ! -OB psolswad(i) = zfsdnad(i, 1) - zfsupad(i, 1) ptopswad(i) = zfsdnad(i, kflev+1) - zfsupad(i, kflev+1) psolswai(i) = zfsdnai(i, 1) - zfsupai(i, 1) ptopswai(i) = zfsdnai(i, kflev+1) - zfsupai(i, kflev+1) ! -fin END DO RETURN END SUBROUTINE sw_lmdar4 ! IM ctes ds clesphys.h SUBROUTINE SWU ! (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, SUBROUTINE swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & paki, pcld, pclear, pdsig, pfact, prmu, psec, pud) USE dimphy USE radiation_ar4_param, ONLY: zpdh2o, zpdumg, zprh2o, zprumg, rtdh2o, & rtdumg, rth2o, rtumg IMPLICIT NONE include "radepsi.h" include "radopt.h" include "YOMCST.h" ! * ARGUMENTS: REAL (KIND=8) psct ! IM ctes ds clesphys.h REAL(KIND=8) RCO2 include "clesphys.h" REAL (KIND=8) pcldsw(kdlon, kflev) REAL (KIND=8) ppmb(kdlon, kflev+1) REAL (KIND=8) ppsol(kdlon) REAL (KIND=8) prmu0(kdlon) REAL (KIND=8) pfrac(kdlon) REAL (KIND=8) ptave(kdlon, kflev) REAL (KIND=8) pwv(kdlon, kflev) REAL (KIND=8) paki(kdlon, 2) REAL (KIND=8) pcld(kdlon, kflev) REAL (KIND=8) pclear(kdlon) REAL (KIND=8) pdsig(kdlon, kflev) REAL (KIND=8) pfact(kdlon) REAL (KIND=8) prmu(kdlon) REAL (KIND=8) psec(kdlon) REAL (KIND=8) pud(kdlon, 5, kflev+1) ! * LOCAL VARIABLES: INTEGER iind(2) REAL (KIND=8) zc1j(kdlon, kflev+1) REAL (KIND=8) zclear(kdlon) REAL (KIND=8) zcloud(kdlon) REAL (KIND=8) zn175(kdlon) REAL (KIND=8) zn190(kdlon) REAL (KIND=8) zo175(kdlon) REAL (KIND=8) zo190(kdlon) REAL (KIND=8) zsign(kdlon) REAL (KIND=8) zr(kdlon, 2) REAL (KIND=8) zsigo(kdlon) REAL (KIND=8) zud(kdlon, 2) REAL (KIND=8) zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw INTEGER jl, jk, jkp1, jkl, jklp1, ja ! ------------------------------------------------------------------ ! * 1. COMPUTES AMOUNTS OF ABSORBERS ! ----------------------------- iind(1) = 1 iind(2) = 2 ! * 1.1 INITIALIZES QUANTITIES ! ---------------------- DO 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. END DO ! * 1.3 AMOUNTS OF ABSORBERS ! -------------------- DO 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. END DO DO jk = 1, kflev jkp1 = jk + 1 jkl = kflev + 1 - jk jklp1 = jkl + 1 DO 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) IF (novlp==1) THEN zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( & zcloud(jl),1.-zepsec)) zc1j(jl, jkl) = 1.0 - zclear(jl) zcloud(jl) = pcldsw(jl, jkl) ELSE IF (novlp==2) THEN zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl)) zc1j(jl, jkl) = zcloud(jl) ELSE IF (novlp==3) THEN zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl)) zcloud(jl) = 1.0 - zclear(jl) zc1j(jl, jkl) = zcloud(jl) END IF END DO END DO DO jl = 1, kdlon pclear(jl) = 1. - zc1j(jl, 1) END DO DO jk = 1, kflev DO jl = 1, kdlon IF (pclear(jl)<1.) THEN pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl)) ELSE pcld(jl, jk) = 0. END IF END DO END DO ! * 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS ! ----------------------------------------------- DO ja = 1, 2 DO jl = 1, kdlon zud(jl, ja) = zud(jl, ja)*psec(jl) END DO END DO CALL swtt1_lmdar4(2, 2, iind, zud, zr) DO ja = 1, 2 DO jl = 1, kdlon paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja) END DO END DO ! ------------------------------------------------------------------ RETURN END SUBROUTINE swu_lmdar4 SUBROUTINE sw1s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, & pfd, pfu) USE dimphy USE radiation_ar4_param, ONLY: rsun, rray USE infotrac_phy, ONLY: type_trac #ifdef REPROBUS USE chem_rep, ONLY: rsuntime, ok_suntime #endif IMPLICIT NONE ! ------------------------------------------------------------------ ! PURPOSE. ! -------- ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). ! METHOD. ! ------- ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO ! CONTINUUM SCATTERING ! 2. 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 REAL (KIND=8) flag_aer REAL (KIND=8) tauae(kdlon, kflev, 2) REAL (KIND=8) pizae(kdlon, kflev, 2) REAL (KIND=8) cgae(kdlon, kflev, 2) REAL (KIND=8) paer(kdlon, kflev, 5) REAL (KIND=8) palbd(kdlon, 2) REAL (KIND=8) palbp(kdlon, 2) REAL (KIND=8) pcg(kdlon, 2, kflev) REAL (KIND=8) pcld(kdlon, kflev) REAL (KIND=8) pcldsw(kdlon, kflev) REAL (KIND=8) pclear(kdlon) REAL (KIND=8) pdsig(kdlon, kflev) REAL (KIND=8) pomega(kdlon, 2, kflev) REAL (KIND=8) poz(kdlon, kflev) REAL (KIND=8) prmu(kdlon) REAL (KIND=8) psec(kdlon) REAL (KIND=8) ptau(kdlon, 2, kflev) REAL (KIND=8) pud(kdlon, 5, kflev+1) REAL (KIND=8) pfd(kdlon, kflev+1) REAL (KIND=8) pfu(kdlon, kflev+1) ! * LOCAL VARIABLES: INTEGER iind(4) REAL (KIND=8) zcgaz(kdlon, kflev) REAL (KIND=8) zdiff(kdlon) REAL (KIND=8) zdirf(kdlon) REAL (KIND=8) zpizaz(kdlon, kflev) REAL (KIND=8) zrayl(kdlon) REAL (KIND=8) zray1(kdlon, kflev+1) REAL (KIND=8) zray2(kdlon, kflev+1) REAL (KIND=8) zrefz(kdlon, 2, kflev+1) REAL (KIND=8) zrj(kdlon, 6, kflev+1) REAL (KIND=8) zrj0(kdlon, 6, kflev+1) REAL (KIND=8) zrk(kdlon, 6, kflev+1) REAL (KIND=8) zrk0(kdlon, 6, kflev+1) REAL (KIND=8) zrmue(kdlon, kflev+1) REAL (KIND=8) zrmu0(kdlon, kflev+1) REAL (KIND=8) zr(kdlon, 4) REAL (KIND=8) ztauaz(kdlon, kflev) REAL (KIND=8) ztra1(kdlon, kflev+1) REAL (KIND=8) ztra2(kdlon, kflev+1) REAL (KIND=8) zw(kdlon, 4) INTEGER jl, jk, k, jaj, ikm1, ikl ! If running with Reporbus, overwrite default values of RSUN. ! Otherwise keep default values from radiation_AR4_param module. IF (type_trac=='repr') THEN #ifdef REPROBUS IF (ok_suntime) THEN rsun(1) = rsuntime(1) rsun(2) = rsuntime(2) END IF WRITE (lunout, *) 'RSUN(1): ', rsun(1) #endif END IF ! ------------------------------------------------------------------ ! * 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON) ! ----------------------- ------------------ ! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING ! ----------------------------------------- DO jl = 1, kdlon zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, & 3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6))))) END DO ! ------------------------------------------------------------------ ! * 2. CONTINUUM SCATTERING CALCULATIONS ! --------------------------------- ! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN ! -------------------------------- CALL swclr_lmdar4(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_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, & zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, & ztra2) ! ------------------------------------------------------------------ ! * 3. OZONE ABSORPTION ! ---------------- iind(1) = 1 iind(2) = 3 iind(3) = 1 iind(4) = 3 ! * 3.1 DOWNWARD FLUXES ! --------------- jaj = 2 DO 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)+pclear(jl)*zrj0( & jl,jaj,kflev+1))*rsun(knu) END DO DO jk = 1, kflev ikl = kflev + 1 - jk DO 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) END DO CALL swtt1_lmdar4(knu, 4, iind, zw, zr) DO 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)+pclear(jl)*zdirf(jl))* & rsun(knu) END DO END DO ! * 3.2 UPWARD FLUXES ! ------------- DO jl = 1, kdlon pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl & )*palbp(jl,knu))*rsun(knu) END DO DO jk = 2, kflev + 1 ikm1 = jk - 1 DO 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 END DO CALL swtt1_lmdar4(knu, 4, iind, zw, zr) DO 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)+pclear(jl)*zdirf(jl))* & rsun(knu) END DO END DO ! ------------------------------------------------------------------ RETURN END SUBROUTINE sw1s_lmdar4 SUBROUTINE sw2s_lmdar4(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 dimphy USE radiation_ar4_param, ONLY: rsun, rray USE infotrac_phy, ONLY: type_trac #ifdef REPROBUS USE chem_rep, ONLY: rsuntime, ok_suntime #endif IMPLICIT NONE include "radepsi.h" ! ------------------------------------------------------------------ ! 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 REAL (KIND=8) flag_aer REAL (KIND=8) tauae(kdlon, kflev, 2) REAL (KIND=8) pizae(kdlon, kflev, 2) REAL (KIND=8) cgae(kdlon, kflev, 2) REAL (KIND=8) paer(kdlon, kflev, 5) REAL (KIND=8) paki(kdlon, 2) REAL (KIND=8) palbd(kdlon, 2) REAL (KIND=8) palbp(kdlon, 2) REAL (KIND=8) pcg(kdlon, 2, kflev) REAL (KIND=8) pcld(kdlon, kflev) REAL (KIND=8) pcldsw(kdlon, kflev) REAL (KIND=8) pclear(kdlon) REAL (KIND=8) pdsig(kdlon, kflev) REAL (KIND=8) pomega(kdlon, 2, kflev) REAL (KIND=8) poz(kdlon, kflev) REAL (KIND=8) pqs(kdlon, kflev) REAL (KIND=8) prmu(kdlon) REAL (KIND=8) psec(kdlon) REAL (KIND=8) ptau(kdlon, 2, kflev) REAL (KIND=8) pud(kdlon, 5, kflev+1) REAL (KIND=8) pwv(kdlon, kflev) REAL (KIND=8) pfdown(kdlon, kflev+1) REAL (KIND=8) pfup(kdlon, kflev+1) ! * LOCAL VARIABLES: INTEGER iind2(2), iind3(3) REAL (KIND=8) zcgaz(kdlon, kflev) REAL (KIND=8) zfd(kdlon, kflev+1) REAL (KIND=8) zfu(kdlon, kflev+1) REAL (KIND=8) zg(kdlon) REAL (KIND=8) zgg(kdlon) REAL (KIND=8) zpizaz(kdlon, kflev) REAL (KIND=8) zrayl(kdlon) REAL (KIND=8) zray1(kdlon, kflev+1) REAL (KIND=8) zray2(kdlon, kflev+1) REAL (KIND=8) zref(kdlon) REAL (KIND=8) zrefz(kdlon, 2, kflev+1) REAL (KIND=8) zre1(kdlon) REAL (KIND=8) zre2(kdlon) REAL (KIND=8) zrj(kdlon, 6, kflev+1) REAL (KIND=8) zrj0(kdlon, 6, kflev+1) REAL (KIND=8) zrk(kdlon, 6, kflev+1) REAL (KIND=8) zrk0(kdlon, 6, kflev+1) REAL (KIND=8) zrl(kdlon, 8) REAL (KIND=8) zrmue(kdlon, kflev+1) REAL (KIND=8) zrmu0(kdlon, kflev+1) REAL (KIND=8) zrmuz(kdlon) REAL (KIND=8) zrneb(kdlon) REAL (KIND=8) zruef(kdlon, 8) REAL (KIND=8) zr1(kdlon) REAL (KIND=8) zr2(kdlon, 2) REAL (KIND=8) zr3(kdlon, 3) REAL (KIND=8) zr4(kdlon) REAL (KIND=8) zr21(kdlon) REAL (KIND=8) zr22(kdlon) REAL (KIND=8) zs(kdlon) REAL (KIND=8) ztauaz(kdlon, kflev) REAL (KIND=8) zto1(kdlon) REAL (KIND=8) ztr(kdlon, 2, kflev+1) REAL (KIND=8) ztra1(kdlon, kflev+1) REAL (KIND=8) ztra2(kdlon, kflev+1) REAL (KIND=8) ztr1(kdlon) REAL (KIND=8) ztr2(kdlon) REAL (KIND=8) zw(kdlon) REAL (KIND=8) zw1(kdlon) REAL (KIND=8) zw2(kdlon, 2) REAL (KIND=8) zw3(kdlon, 3) REAL (KIND=8) zw4(kdlon) REAL (KIND=8) zw5(kdlon) INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs REAL (KIND=8) zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11 ! If running with Reporbus, overwrite default values of RSUN. ! Otherwise keep default values from radiation_AR4_param module. IF (type_trac=='repr') THEN #ifdef REPROBUS IF (ok_suntime) THEN rsun(1) = rsuntime(1) rsun(2) = rsuntime(2) END IF #endif END IF ! ------------------------------------------------------------------ ! * 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_lmdar4(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_lmdar4(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_lmdar4(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_lmdar4(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_lmdar4(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_lmdar4(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_lmdar4(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_lmdar4(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_lmdar4 SUBROUTINE swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, & pdsig, prayl, psec, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmu0, & ptauaz, ptra1, ptra2) USE dimphy USE radiation_ar4_param, ONLY: taua, rpiza, rcga IMPLICIT NONE include "radepsi.h" include "radopt.h" ! ------------------------------------------------------------------ ! PURPOSE. ! -------- ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF ! CLEAR-SKY COLUMN ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 94-11-15 ! ------------------------------------------------------------------ ! * ARGUMENTS: INTEGER knu ! -OB REAL (KIND=8) flag_aer REAL (KIND=8) tauae(kdlon, kflev, 2) REAL (KIND=8) pizae(kdlon, kflev, 2) REAL (KIND=8) cgae(kdlon, kflev, 2) REAL (KIND=8) paer(kdlon, kflev, 5) REAL (KIND=8) palbp(kdlon, 2) REAL (KIND=8) pdsig(kdlon, kflev) REAL (KIND=8) prayl(kdlon) REAL (KIND=8) psec(kdlon) REAL (KIND=8) pcgaz(kdlon, kflev) REAL (KIND=8) ppizaz(kdlon, kflev) REAL (KIND=8) pray1(kdlon, kflev+1) REAL (KIND=8) pray2(kdlon, kflev+1) REAL (KIND=8) prefz(kdlon, 2, kflev+1) REAL (KIND=8) prj(kdlon, 6, kflev+1) REAL (KIND=8) prk(kdlon, 6, kflev+1) REAL (KIND=8) prmu0(kdlon, kflev+1) REAL (KIND=8) ptauaz(kdlon, kflev) REAL (KIND=8) ptra1(kdlon, kflev+1) REAL (KIND=8) ptra2(kdlon, kflev+1) ! * LOCAL VARIABLES: REAL (KIND=8) zc0i(kdlon, kflev+1) REAL (KIND=8) zcle0(kdlon, kflev) REAL (KIND=8) zclear(kdlon) REAL (KIND=8) zr21(kdlon) REAL (KIND=8) zr23(kdlon) REAL (KIND=8) zss0(kdlon) REAL (KIND=8) zscat(kdlon) REAL (KIND=8) ztr(kdlon, 2, kflev+1) INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in REAL (KIND=8) ztray, zgar, zratio, zff, zfacoa, zcorae REAL (KIND=8) zmue, zgap, zww, zto, zden, zmu1, zden1 REAL (KIND=8) zbmu0, zbmu1, zre11 ! ------------------------------------------------------------------ ! * 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH ! -------------------------------------------- ! cdir collapse DO jk = 1, kflev + 1 DO ja = 1, 6 DO jl = 1, kdlon prj(jl, ja, jk) = 0. prk(jl, ja, jk) = 0. END DO END DO END DO DO jk = 1, kflev ! -OB ! DO 104 JL = 1, KDLON ! PCGAZ(JL,JK) = 0. ! PPIZAZ(JL,JK) = 0. ! PTAUAZ(JL,JK) = 0. ! 104 CONTINUE ! -OB ! 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 ! -OB DO jl = 1, kdlon ptauaz(jl, jk) = flag_aer*tauae(jl, jk, knu) ppizaz(jl, jk) = flag_aer*pizae(jl, jk, knu) pcgaz(jl, jk) = flag_aer*cgae(jl, jk, knu) END DO IF (flag_aer>0) THEN ! -OB DO jl = 1, kdlon ! 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)/(1.- & ppizaz(jl,jk)*zff) END DO ELSE DO jl = 1, kdlon ztray = prayl(jl)*pdsig(jl, jk) ptauaz(jl, jk) = ztray pcgaz(jl, jk) = 0. ppizaz(jl, jk) = 1. - repsct END DO END IF ! check flag_aer ! 107 CONTINUE ! PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5) ! $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON) ! 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5) END DO ! ------------------------------------------------------------------ ! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL ! ---------------------------------------------- DO jl = 1, kdlon zr23(jl) = 0. zc0i(jl, kflev+1) = 0. zclear(jl) = 1. zscat(jl) = 0. END DO jk = 1 jkl = kflev + 1 - jk jklp1 = jkl + 1 DO 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) IF (novlp==1) THEN ! * maximum-random zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ & (1.0-min(zscat(jl),1.-zepsec)) zc0i(jl, jkl) = 1.0 - zclear(jl) zscat(jl) = zss0(jl) ELSE IF (novlp==2) THEN ! * maximum zscat(jl) = max(zss0(jl), zscat(jl)) zc0i(jl, jkl) = zscat(jl) ELSE IF (novlp==3) THEN ! * random zclear(jl) = zclear(jl)*(1.0-zss0(jl)) zscat(jl) = 1.0 - zclear(jl) zc0i(jl, jkl) = zscat(jl) END IF END DO DO jk = 2, kflev jkl = kflev + 1 - jk jklp1 = jkl + 1 DO 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) IF (novlp==1) THEN ! * maximum-random zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ & (1.0-min(zscat(jl),1.-zepsec)) zc0i(jl, jkl) = 1.0 - zclear(jl) zscat(jl) = zss0(jl) ELSE IF (novlp==2) THEN ! * maximum zscat(jl) = max(zss0(jl), zscat(jl)) zc0i(jl, jkl) = zscat(jl) ELSE IF (novlp==3) THEN ! * random zclear(jl) = zclear(jl)*(1.0-zss0(jl)) zscat(jl) = 1.0 - zclear(jl) zc0i(jl, jkl) = zscat(jl) END IF END DO END DO ! ------------------------------------------------------------------ ! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING ! ----------------------------------------------- DO 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. END DO DO jk = 2, kflev + 1 jkm1 = jk - 1 DO jl = 1, kdlon ! ------------------------------------------------------------------ ! * 3.1 EQUIVALENT ZENITH ANGLE ! ----------------------- zmue = (1.-zc0i(jl,jk))*psec(jl) + zc0i(jl, jk)*1.66 prmu0(jl, jk) = 1./zmue ! ------------------------------------------------------------------ ! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS ! ---------------------------------------------------- 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 + (1-zww)*(1.-zww+2.*zbmu0*zww) & *zto*zto*zmue*zmue pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden ptra1(jl, jkm1) = 1./zden zmu1 = 0.5 zbmu1 = 0.5 - 0.75*zgap*zmu1 zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww & )*zto*zto/zmu1/zmu1 pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1 ptra2(jl, jkm1) = 1./zden1 prefz(jl, 1, jk) = (pray1(jl,jkm1)+prefz(jl,1,jkm1)*ptra1(jl,jkm1)* & ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1,jkm1))) ztr(jl, 1, jkm1) = (ptra1(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, & jkm1))) prefz(jl, 2, jk) = (pray1(jl,jkm1)+prefz(jl,2,jkm1)*ptra1(jl,jkm1)* & ptra2(jl,jkm1)) ztr(jl, 2, jkm1) = ptra1(jl, jkm1) END DO END DO DO jl = 1, kdlon zmue = (1.-zc0i(jl,1))*psec(jl) + zc0i(jl, 1)*1.66 prmu0(jl, 1) = 1./zmue END DO ! ------------------------------------------------------------------ ! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL ! ------------------------------------------------- IF (knu==1) THEN jaj = 2 DO jl = 1, kdlon prj(jl, jaj, kflev+1) = 1. prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1) END DO DO jk = 1, kflev jkl = kflev + 1 - jk jklp1 = jkl + 1 DO 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) END DO END DO ELSE DO jaj = 1, 2 DO jl = 1, kdlon prj(jl, jaj, kflev+1) = 1. prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1) END DO DO jk = 1, kflev jkl = kflev + 1 - jk jklp1 = jkl + 1 DO 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) END DO END DO END DO END IF ! ------------------------------------------------------------------ RETURN END SUBROUTINE swclr_lmdar4 SUBROUTINE swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, prayl, psec, & ptau, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, & ptra2) USE dimphy IMPLICIT NONE include "radepsi.h" include "radopt.h" ! ------------------------------------------------------------------ ! PURPOSE. ! -------- ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF ! CONTINUUM SCATTERING ! METHOD. ! ------- ! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL ! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION) ! 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 ! ------------------------------------------------------------------ ! * ARGUMENTS: INTEGER knu REAL (KIND=8) palbd(kdlon, 2) REAL (KIND=8) pcg(kdlon, 2, kflev) REAL (KIND=8) pcld(kdlon, kflev) REAL (KIND=8) pdsig(kdlon, kflev) REAL (KIND=8) pomega(kdlon, 2, kflev) REAL (KIND=8) prayl(kdlon) REAL (KIND=8) psec(kdlon) REAL (KIND=8) ptau(kdlon, 2, kflev) REAL (KIND=8) pray1(kdlon, kflev+1) REAL (KIND=8) pray2(kdlon, kflev+1) REAL (KIND=8) prefz(kdlon, 2, kflev+1) REAL (KIND=8) prj(kdlon, 6, kflev+1) REAL (KIND=8) prk(kdlon, 6, kflev+1) REAL (KIND=8) prmue(kdlon, kflev+1) REAL (KIND=8) pcgaz(kdlon, kflev) REAL (KIND=8) ppizaz(kdlon, kflev) REAL (KIND=8) ptauaz(kdlon, kflev) REAL (KIND=8) ptra1(kdlon, kflev+1) REAL (KIND=8) ptra2(kdlon, kflev+1) ! * LOCAL VARIABLES: REAL (KIND=8) zc1i(kdlon, kflev+1) REAL (KIND=8) zcleq(kdlon, kflev) REAL (KIND=8) zclear(kdlon) REAL (KIND=8) zcloud(kdlon) REAL (KIND=8) zgg(kdlon) REAL (KIND=8) zref(kdlon) REAL (KIND=8) zre1(kdlon) REAL (KIND=8) zre2(kdlon) REAL (KIND=8) zrmuz(kdlon) REAL (KIND=8) zrneb(kdlon) REAL (KIND=8) zr21(kdlon) REAL (KIND=8) zr22(kdlon) REAL (KIND=8) zr23(kdlon) REAL (KIND=8) zss1(kdlon) REAL (KIND=8) zto1(kdlon) REAL (KIND=8) ztr(kdlon, 2, kflev+1) REAL (KIND=8) ztr1(kdlon) REAL (KIND=8) ztr2(kdlon) REAL (KIND=8) zw(kdlon) INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj REAL (KIND=8) zfacoa, zfacoc, zcorae, zcorcd REAL (KIND=8) zmue, zgap, zww, zto, zden, zden1 REAL (KIND=8) zmu1, zre11, zbmu0, zbmu1 ! ------------------------------------------------------------------ ! * 1. INITIALIZATION ! -------------- DO jk = 1, kflev + 1 DO ja = 1, 6 DO jl = 1, kdlon prj(jl, ja, jk) = 0. prk(jl, ja, jk) = 0. END DO END DO END DO ! ------------------------------------------------------------------ ! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL ! ---------------------------------------------- DO jl = 1, kdlon zr23(jl) = 0. zc1i(jl, kflev+1) = 0. zclear(jl) = 1. zcloud(jl) = 0. END DO jk = 1 jkl = kflev + 1 - jk jklp1 = jkl + 1 DO jl = 1, kdlon zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl) zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*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)) + & (1.0-pcld(jl,jkl))*(1.0-zr21(jl)) zcleq(jl, jkl) = zss1(jl) IF (novlp==1) THEN ! * maximum-random zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ & (1.0-min(zcloud(jl),1.-zepsec)) zc1i(jl, jkl) = 1.0 - zclear(jl) zcloud(jl) = zss1(jl) ELSE IF (novlp==2) THEN ! * maximum zcloud(jl) = max(zss1(jl), zcloud(jl)) zc1i(jl, jkl) = zcloud(jl) ELSE IF (novlp==3) THEN ! * random zclear(jl) = zclear(jl)*(1.0-zss1(jl)) zcloud(jl) = 1.0 - zclear(jl) zc1i(jl, jkl) = zcloud(jl) END IF END DO DO jk = 2, kflev jkl = kflev + 1 - jk jklp1 = jkl + 1 DO jl = 1, kdlon zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl) zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*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)) + & (1.0-pcld(jl,jkl))*(1.0-zr21(jl)) zcleq(jl, jkl) = zss1(jl) IF (novlp==1) THEN ! * maximum-random zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ & (1.0-min(zcloud(jl),1.-zepsec)) zc1i(jl, jkl) = 1.0 - zclear(jl) zcloud(jl) = zss1(jl) ELSE IF (novlp==2) THEN ! * maximum zcloud(jl) = max(zss1(jl), zcloud(jl)) zc1i(jl, jkl) = zcloud(jl) ELSE IF (novlp==3) THEN ! * random zclear(jl) = zclear(jl)*(1.0-zss1(jl)) zcloud(jl) = 1.0 - zclear(jl) zc1i(jl, jkl) = zcloud(jl) END IF END DO END DO ! ------------------------------------------------------------------ ! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING ! ----------------------------------------------- DO 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. END DO DO jk = 2, kflev + 1 jkm1 = jk - 1 DO jl = 1, kdlon zrneb(jl) = pcld(jl, jkm1) zre1(jl) = 0. ztr1(jl) = 0. zre2(jl) = 0. ztr2(jl) = 0. ! ------------------------------------------------------------------ ! * 3.1 EQUIVALENT ZENITH ANGLE ! ----------------------- zmue = (1.-zc1i(jl,jk))*psec(jl) + zc1i(jl, jk)*1.66 prmue(jl, jk) = 1./zmue ! ------------------------------------------------------------------ ! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS ! ---------------------------------------------------- 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 + (1-zww)*(1.-zww+2.*zbmu0*zww) & *zto*zto*zmue*zmue pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden ptra1(jl, jkm1) = 1./zden ! PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1) zmu1 = 0.5 zbmu1 = 0.5 - 0.75*zgap*zmu1 zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww & )*zto*zto/zmu1/zmu1 pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1 ptra2(jl, jkm1) = 1./zden1 ! ------------------------------------------------------------------ ! * 3.3 EFFECT OF CLOUD LAYER ! --------------------- zw(jl) = pomega(jl, knu, jkm1) zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + 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) + (1.-zr22(jl))*pcgaz(jl, jkm1) ! Modif PhD - JJM 19/03/96 pour erreurs arrondis ! machine ! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL) IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==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) END DO CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2) DO jl = 1, kdlon prefz(jl, 1, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,1,jkm1)* & ptra1(jl,jkm1)*ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, & jkm1))) + zrneb(jl)*zre2(jl) ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, & jkm1)*prefz(jl,1,jkm1)))*(1.-zrneb(jl)) prefz(jl, 2, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,2,jkm1)* & ptra1(jl,jkm1)*ptra2(jl,jkm1)) + zrneb(jl)*zre1(jl) ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + ptra1(jl, jkm1)*(1.-zrneb(jl)) END DO END DO DO jl = 1, kdlon zmue = (1.-zc1i(jl,1))*psec(jl) + zc1i(jl, 1)*1.66 prmue(jl, 1) = 1./zmue END DO ! ------------------------------------------------------------------ ! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL ! ------------------------------------------------- IF (knu==1) THEN jaj = 2 DO jl = 1, kdlon prj(jl, jaj, kflev+1) = 1. prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1) END DO DO jk = 1, kflev jkl = kflev + 1 - jk jklp1 = jkl + 1 DO 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) END DO END DO ELSE DO jaj = 1, 2 DO jl = 1, kdlon prj(jl, jaj, kflev+1) = 1. prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1) END DO DO jk = 1, kflev jkl = kflev + 1 - jk jklp1 = jkl + 1 DO 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) END DO END DO END DO END IF ! ------------------------------------------------------------------ RETURN END SUBROUTINE swr_lmdar4 SUBROUTINE swde_lmdar4(pgg, pref, prmuz, pto1, pw, pre1, pre2, ptr1, ptr2) USE dimphy IMPLICIT NONE ! ------------------------------------------------------------------ ! PURPOSE. ! -------- ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY ! LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION. ! METHOD. ! ------- ! STANDARD DELTA-EDDINGTON LAYER CALCULATIONS. ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 88-12-15 ! ------------------------------------------------------------------ ! * ARGUMENTS: REAL (KIND=8) pgg(kdlon) ! ASSYMETRY FACTOR REAL (KIND=8) pref(kdlon) ! REFLECTIVITY OF THE UNDERLYING LAYER REAL (KIND=8) prmuz(kdlon) ! COSINE OF SOLAR ZENITH ANGLE REAL (KIND=8) pto1(kdlon) ! OPTICAL THICKNESS REAL (KIND=8) pw(kdlon) ! SINGLE SCATTERING ALBEDO REAL (KIND=8) pre1(kdlon) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION) REAL (KIND=8) pre2(kdlon) ! LAYER REFLECTIVITY REAL (KIND=8) ptr1(kdlon) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION) REAL (KIND=8) ptr2(kdlon) ! LAYER TRANSMISSIVITY ! * LOCAL VARIABLES: INTEGER jl REAL (KIND=8) zff, zgp, ztop, zwcp, zdt, zx1, zwm REAL (KIND=8) zrm2, zrk, zx2, zrp, zalpha, zbeta, zarg REAL (KIND=8) zexmu0, zarg2, zexkp, zexkm, zxp2p, zxm2p, zap2b, zam2b REAL (KIND=8) za11, za12, za13, za21, za22, za23 REAL (KIND=8) zdena, zc1a, zc2a, zri0a, zri1a REAL (KIND=8) zri0b, zri1b REAL (KIND=8) zb21, zb22, zb23, zdenb, zc1b, zc2b REAL (KIND=8) zri0c, zri1c, zri0d, zri1d ! ------------------------------------------------------------------ ! * 1. DELTA-EDDINGTON CALCULATIONS DO jl = 1, kdlon ! * 1.1 SET UP THE DELTA-MODIFIED PARAMETERS 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._8) zexmu0 = exp(-zarg) zarg2 = min(zrk*ztop, 200._8) zexkp = exp(zarg2) zexkm = 1./zexkp zxp2p = 1. + zdt*zrp zxm2p = 1. - zdt*zrp zap2b = zalpha + zdt*zbeta zam2b = zalpha - zdt*zbeta ! * 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER 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) ! * 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER 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) END DO RETURN END SUBROUTINE swde_lmdar4 SUBROUTINE swtt_lmdar4(knu, ka, pu, ptr) USE dimphy USE radiation_ar4_param, ONLY: apad, bpad, d IMPLICIT NONE ! ----------------------------------------------------------------------- ! PURPOSE. ! -------- ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL ! INTERVALS. ! METHOD. ! ------- ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS ! AND HORNER'S ALGORITHM. ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 88-12-15 ! ----------------------------------------------------------------------- ! * ARGUMENTS INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL INTEGER ka ! INDEX OF THE ABSORBER REAL (KIND=8) pu(kdlon) ! ABSORBER AMOUNT REAL (KIND=8) ptr(kdlon) ! TRANSMISSION FUNCTION ! * LOCAL VARIABLES: REAL (KIND=8) zr1(kdlon), zr2(kdlon) INTEGER jl, i, j ! ----------------------------------------------------------------------- ! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION DO jl = 1, kdlon zr1(jl) = apad(knu, ka, 1) + pu(jl)*(apad(knu,ka,2)+pu(jl)*(apad(knu,ka, & 3)+pu(jl)*(apad(knu,ka,4)+pu(jl)*(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) & +pu(jl)*(apad(knu,ka,7))))))) zr2(jl) = bpad(knu, ka, 1) + pu(jl)*(bpad(knu,ka,2)+pu(jl)*(bpad(knu,ka, & 3)+pu(jl)*(bpad(knu,ka,4)+pu(jl)*(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) & +pu(jl)*(bpad(knu,ka,7))))))) ! * 2. ADD THE BACKGROUND TRANSMISSION ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka) END DO RETURN END SUBROUTINE swtt_lmdar4 SUBROUTINE swtt1_lmdar4(knu, kabs, kind, pu, ptr) USE dimphy USE radiation_ar4_param, ONLY: apad, bpad, d IMPLICIT NONE ! ----------------------------------------------------------------------- ! PURPOSE. ! -------- ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL ! INTERVALS. ! METHOD. ! ------- ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS ! AND HORNER'S ALGORITHM. ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 95-01-20 ! ----------------------------------------------------------------------- ! * ARGUMENTS: INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL INTEGER kabs ! NUMBER OF ABSORBERS INTEGER kind(kabs) ! INDICES OF THE ABSORBERS REAL (KIND=8) pu(kdlon, kabs) ! ABSORBER AMOUNT REAL (KIND=8) ptr(kdlon, kabs) ! TRANSMISSION FUNCTION ! * LOCAL VARIABLES: REAL (KIND=8) zr1(kdlon) REAL (KIND=8) zr2(kdlon) REAL (KIND=8) zu(kdlon) INTEGER jl, ja, i, j, ia ! ----------------------------------------------------------------------- ! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION DO ja = 1, kabs ia = kind(ja) DO jl = 1, kdlon zu(jl) = pu(jl, ja) zr1(jl) = apad(knu, ia, 1) + zu(jl)*(apad(knu,ia,2)+zu(jl)*(apad(knu, & ia,3)+zu(jl)*(apad(knu,ia,4)+zu(jl)*(apad(knu,ia,5)+zu(jl)*(apad(knu, & ia,6)+zu(jl)*(apad(knu,ia,7))))))) zr2(jl) = bpad(knu, ia, 1) + zu(jl)*(bpad(knu,ia,2)+zu(jl)*(bpad(knu, & ia,3)+zu(jl)*(bpad(knu,ia,4)+zu(jl)*(bpad(knu,ia,5)+zu(jl)*(bpad(knu, & ia,6)+zu(jl)*(bpad(knu,ia,7))))))) ! * 2. ADD THE BACKGROUND TRANSMISSION ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia) END DO END DO RETURN END SUBROUTINE swtt1_lmdar4 ! IM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, SUBROUTINE lw_lmdar4(ppmb, pdp, ppsol, pdt0, pemis, ptl, ptave, pwv, pozon, & paer, pcldld, pcldlu, pview, pcolr, pcolr0, ptoplw, psollw, ptoplw0, & psollw0, psollwdown, & ! IM . ! psollwdown,psollwdownclr, ! IM . ptoplwdown,ptoplwdownclr) plwup, plwdn, plwup0, plwdn0) USE dimphy USE print_control_mod, ONLY: lunout IMPLICIT NONE include "raddimlw.h" include "YOMCST.h" ! ----------------------------------------------------------------------- ! METHOD. ! ------- ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF ! ABSORBERS. ! 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. ! 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE ! BOUNDARIES. ! 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. ! 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES. ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 89-07-14 ! ----------------------------------------------------------------------- ! IM ctes ds clesphys.h ! REAL(KIND=8) RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97) ! REAL(KIND=8) RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97) ! REAL(KIND=8) RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97) ! REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* ! 137.3686/28.97) ! REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* ! 120.9140/28.97) include "clesphys.h" REAL (KIND=8) pcldld(kdlon, kflev) ! DOWNWARD EFFECTIVE CLOUD COVER REAL (KIND=8) pcldlu(kdlon, kflev) ! UPWARD EFFECTIVE CLOUD COVER REAL (KIND=8) pdp(kdlon, kflev) ! LAYER PRESSURE THICKNESS (Pa) REAL (KIND=8) pdt0(kdlon) ! SURFACE TEMPERATURE DISCONTINUITY (K) REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF LEVEL PRESSURE (mb) REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (Pa) REAL (KIND=8) pozon(kdlon, kflev) ! O3 mass fraction REAL (KIND=8) ptl(kdlon, kflev+1) ! HALF LEVEL TEMPERATURE (K) REAL (KIND=8) paer(kdlon, kflev, 5) ! OPTICAL THICKNESS OF THE AEROSOLS REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K) REAL (KIND=8) pview(kdlon) ! COSECANT OF VIEWING ANGLE REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (kg/kg) REAL (KIND=8) pcolr(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day) REAL (KIND=8) pcolr0(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day) clear-sky REAL (KIND=8) ptoplw(kdlon) ! LONGWAVE FLUX AT T.O.A. REAL (KIND=8) psollw(kdlon) ! LONGWAVE FLUX AT SURFACE REAL (KIND=8) ptoplw0(kdlon) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY) REAL (KIND=8) psollw0(kdlon) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY) ! Rajout LF REAL (KIND=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface ! Rajout IM ! IM real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at ! surface ! IM real(kind=8) ptoplwdown(kdlon) ! LONGWAVE downwards flux at ! T.O.A. ! IM real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at ! T.O.A. ! IM REAL (KIND=8) plwup(kdlon, kflev+1) ! LW up total sky REAL (KIND=8) plwup0(kdlon, kflev+1) ! LW up clear sky REAL (KIND=8) plwdn(kdlon, kflev+1) ! LW down total sky REAL (KIND=8) plwdn0(kdlon, kflev+1) ! LW down clear sky ! ------------------------------------------------------------------------- REAL (KIND=8) zabcu(kdlon, nua, 3*kflev+1) REAL (KIND=8) zoz(kdlon, kflev) ! equivalent pressure of ozone in a layer, in Pa ! ym REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; ! 2:down) ! ym REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES ! ym REAL(KIND=8) ZBINT(KDLON,KFLEV+1) ! Intermediate ! variable ! ym REAL(KIND=8) ZBSUI(KDLON) ! Intermediate ! variable ! ym REAL(KIND=8) ZCTS(KDLON,KFLEV) ! Intermediate ! variable ! ym REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate ! variable ! ym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB REAL (KIND=8), ALLOCATABLE, SAVE :: zflux(:, :, :) ! RADIATIVE FLUXES (1:up; 2:down) REAL (KIND=8), ALLOCATABLE, SAVE :: zfluc(:, :, :) ! CLEAR-SKY RADIATIVE FLUXES REAL (KIND=8), ALLOCATABLE, SAVE :: zbint(:, :) ! Intermediate variable REAL (KIND=8), ALLOCATABLE, SAVE :: zbsui(:) ! Intermediate variable REAL (KIND=8), ALLOCATABLE, SAVE :: zcts(:, :) ! Intermediate variable REAL (KIND=8), ALLOCATABLE, SAVE :: zcntrb(:, :, :) ! Intermediate variable !$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB) INTEGER ilim, i, k, kpl1 INTEGER lw0pas ! Every lw0pas steps, clear-sky is done PARAMETER (lw0pas=1) INTEGER lwpas ! Every lwpas steps, cloudy-sky is done PARAMETER (lwpas=1) INTEGER itaplw0, itaplw LOGICAL appel1er SAVE appel1er, itaplw0, itaplw !$OMP THREADPRIVATE(appel1er, itaplw0, itaplw) DATA appel1er/.TRUE./ DATA itaplw0, itaplw/0, 0/ ! ------------------------------------------------------------------ IF (appel1er) THEN WRITE (lunout, *) 'LW clear-sky calling frequency: ', lw0pas WRITE (lunout, *) 'LW cloudy-sky calling frequency: ', lwpas WRITE (lunout, *) ' In general, they should be 1' ! ym ALLOCATE (zflux(kdlon,2,kflev+1)) ALLOCATE (zfluc(kdlon,2,kflev+1)) ALLOCATE (zbint(kdlon,kflev+1)) ALLOCATE (zbsui(kdlon)) ALLOCATE (zcts(kdlon,kflev)) ALLOCATE (zcntrb(kdlon,kflev+1,kflev+1)) appel1er = .FALSE. END IF IF (mod(itaplw0,lw0pas)==0) THEN ! Compute equivalent pressure of ozone from mass fraction: DO k = 1, kflev DO i = 1, kdlon zoz(i, k) = pozon(i, k)*pdp(i, k) END DO END DO ! IM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12, CALL lwu_lmdar4(paer, pdp, ppmb, ppsol, zoz, ptave, pview, pwv, zabcu) CALL lwbv_lmdar4(ilim, pdp, pdt0, pemis, ppmb, ptl, ptave, zabcu, zfluc, & zbint, zbsui, zcts, zcntrb) itaplw0 = 0 END IF itaplw0 = itaplw0 + 1 IF (mod(itaplw,lwpas)==0) THEN CALL lwc_lmdar4(ilim, pcldld, pcldlu, pemis, zfluc, zbint, zbsui, zcts, & zcntrb, zflux) itaplw = 0 END IF itaplw = itaplw + 1 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) END DO END DO 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) psollw0(i) = -zfluc(i, 1, 1) - zfluc(i, 2, 1) ptoplw0(i) = zfluc(i, 1, kflev+1) + zfluc(i, 2, kflev+1) psollwdown(i) = -zflux(i, 2, 1) ! IM attention aux signes !; LWtop >0, LWdn < 0 DO k = 1, kflev + 1 plwup(i, k) = zflux(i, 1, k) plwup0(i, k) = zfluc(i, 1, k) plwdn(i, k) = zflux(i, 2, k) plwdn0(i, k) = zfluc(i, 2, k) END DO END DO ! ------------------------------------------------------------------ RETURN END SUBROUTINE lw_lmdar4 ! IM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12, SUBROUTINE lwu_lmdar4(paer, pdp, ppmb, ppsol, poz, ptave, pview, pwv, pabcu) USE dimphy USE radiation_ar4_param, ONLY: tref, rt1, raer, at, bt, oct USE infotrac_phy, ONLY: type_trac #ifdef REPROBUS USE chem_rep, ONLY: rch42d, rn2o2d, rcfc112d, rcfc122d, ok_rtime2d #endif IMPLICIT NONE include "raddimlw.h" include "YOMCST.h" include "radepsi.h" include "radopt.h" ! PURPOSE. ! -------- ! COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND ! TEMPERATURE EFFECTS ! METHOD. ! ------- ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF ! ABSORBERS. ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 89-07-14 ! Voigt lines (loop 404 modified) - JJM & PhD - 01/96 ! ----------------------------------------------------------------------- ! * ARGUMENTS: ! IM ctes ds clesphys.h ! REAL(KIND=8) RCO2 ! REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12 include "clesphys.h" REAL (KIND=8) paer(kdlon, kflev, 5) REAL (KIND=8) pdp(kdlon, kflev) REAL (KIND=8) ppmb(kdlon, kflev+1) REAL (KIND=8) ppsol(kdlon) REAL (KIND=8) poz(kdlon, kflev) REAL (KIND=8) ptave(kdlon, kflev) REAL (KIND=8) pview(kdlon) REAL (KIND=8) pwv(kdlon, kflev) REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS ! ----------------------------------------------------------------------- ! * LOCAL VARIABLES: REAL (KIND=8) zably(kdlon, nua, 3*kflev+1) REAL (KIND=8) zduc(kdlon, 3*kflev+1) REAL (KIND=8) zphio(kdlon) REAL (KIND=8) zpsc2(kdlon) REAL (KIND=8) zpsc3(kdlon) REAL (KIND=8) zpsh1(kdlon) REAL (KIND=8) zpsh2(kdlon) REAL (KIND=8) zpsh3(kdlon) REAL (KIND=8) zpsh4(kdlon) REAL (KIND=8) zpsh5(kdlon) REAL (KIND=8) zpsh6(kdlon) REAL (KIND=8) zpsio(kdlon) REAL (KIND=8) ztcon(kdlon) REAL (KIND=8) zphm6(kdlon) REAL (KIND=8) zpsm6(kdlon) REAL (KIND=8) zphn6(kdlon) REAL (KIND=8) zpsn6(kdlon) REAL (KIND=8) zssig(kdlon, 3*kflev+1) REAL (KIND=8) ztavi(kdlon) REAL (KIND=8) zuaer(kdlon, ninter) REAL (KIND=8) zxoz(kdlon) REAL (KIND=8) zxwv(kdlon) 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 (KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup REAL (KIND=8) zfppw, ztx, ztx2, zzably REAL (KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3 REAL (KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6 REAL (KIND=8) zcac8, zcbc8 REAL (KIND=8) zalup, zdiff REAL (KIND=8) pvgco2, pvgh2o, pvgo3 REAL (KIND=8) r10e ! DECIMAL/NATURAL LOG.FACTOR PARAMETER (r10e=0.4342945) ! ----------------------------------------------------------------------- IF (levoigt) THEN pvgco2 = 60. pvgh2o = 30. pvgo3 = 400. ELSE pvgco2 = 0. pvgh2o = 0. pvgo3 = 0. END IF ! * 2. PRESSURE OVER GAUSS SUB-LEVELS ! ------------------------------ DO jl = 1, kdlon zssig(jl, 1) = ppmb(jl, 1)*100. END DO DO jk = 1, kflev jkj = (jk-1)*ng1p1 + 1 jkjr = jkj jkjp = jkj + ng1p1 DO jl = 1, kdlon zssig(jl, jkjp) = ppmb(jl, jk+1)*100. END DO DO ig1 = 1, ng1 jkj = jkj + 1 DO jl = 1, kdlon zssig(jl, jkj) = (zssig(jl,jkjr)+zssig(jl,jkjp))*0.5 + & rt1(ig1)*(zssig(jl,jkjp)-zssig(jl,jkjr))*0.5 END DO END DO END DO ! ----------------------------------------------------------------------- ! * 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS ! -------------------------------------------------- DO jki = 1, 3*kflev jkip1 = jki + 1 DO 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))/(10.*rg) END DO END DO DO jk = 1, kflev jkp1 = jk + 1 jkl = kflev + 1 - jk DO jl = 1, kdlon zxwv(jl) = max(pwv(jl,jk), zepscq) zxoz(jl) = max(poz(jl,jk)/pdp(jl,jk), zepsco) END DO jkj = (jk-1)*ng1p1 + 1 jkjpn = jkj + ng1 DO jkk = jkj, jkjpn DO 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 END DO END DO END DO ! ----------------------------------------------------------------------- ! * 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE ! -------------------------------------------------- DO ja = 1, nua DO jl = 1, kdlon pabcu(jl, ja, 3*kflev+1) = 0. END DO END DO DO jk = 1, kflev jj = (jk-1)*ng1p1 + 1 jjpn = jj + ng1 jkl = kflev + 1 - jk ! * 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE ! -------------------------------------------------- jae1 = 3*kflev + 1 - jj jae2 = 3*kflev + 1 - (jj+1) jae3 = 3*kflev + 1 - jjpn DO jae = 1, 5 DO jl = 1, kdlon zuaer(jl, jae) = (raer(jae,1)*paer(jl,jkl,1)+raer(jae,2)*paer(jl,jkl, & 2)+raer(jae,3)*paer(jl,jkl,3)+raer(jae,4)*paer(jl,jkl,4)+ & raer(jae,5)*paer(jl,jkl,5))/(zduc(jl,jae1)+zduc(jl,jae2)+zduc(jl, & jae3)) END DO END DO ! * 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS ! -------------------------------------------------- DO 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._8), 6._8) 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) END DO DO 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._8, 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)) END DO DO jkk = jj, jjpn jc = 3*kflev + 1 - jkk jcp1 = jc + 1 DO jl = 1, kdlon zdiff = pview(jl) pabcu(jl, 10, jc) = pabcu(jl, 10, jcp1) + zably(jl, 10, jc)*zdiff pabcu(jl, 11, jc) = pabcu(jl, 11, jcp1) + zably(jl, 11, jc)*ztcon(jl) & *zdiff pabcu(jl, 12, jc) = pabcu(jl, 12, jcp1) + zably(jl, 12, jc)*zphio(jl) & *zdiff pabcu(jl, 13, jc) = pabcu(jl, 13, jcp1) + zably(jl, 13, jc)*zpsio(jl) & *zdiff pabcu(jl, 7, jc) = pabcu(jl, 7, jcp1) + zably(jl, 9, jc)*zpsc2(jl)* & zdiff pabcu(jl, 8, jc) = pabcu(jl, 8, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* & zdiff pabcu(jl, 9, jc) = pabcu(jl, 9, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* & zdiff pabcu(jl, 1, jc) = pabcu(jl, 1, jcp1) + zably(jl, 6, jc)*zpsh1(jl)* & zdiff pabcu(jl, 2, jc) = pabcu(jl, 2, jcp1) + zably(jl, 6, jc)*zpsh2(jl)* & zdiff pabcu(jl, 3, jc) = pabcu(jl, 3, jcp1) + zably(jl, 6, jc)*zpsh5(jl)* & zdiff pabcu(jl, 4, jc) = pabcu(jl, 4, jcp1) + zably(jl, 6, jc)*zpsh3(jl)* & zdiff pabcu(jl, 5, jc) = pabcu(jl, 5, jcp1) + zably(jl, 6, jc)*zpsh4(jl)* & zdiff pabcu(jl, 6, jc) = pabcu(jl, 6, jcp1) + zably(jl, 6, jc)*zpsh6(jl)* & zdiff pabcu(jl, 14, jc) = pabcu(jl, 14, jcp1) + zuaer(jl, 1)*zduc(jl, jc)* & zdiff pabcu(jl, 15, jc) = pabcu(jl, 15, jcp1) + zuaer(jl, 2)*zduc(jl, jc)* & zdiff pabcu(jl, 16, jc) = pabcu(jl, 16, jcp1) + zuaer(jl, 3)*zduc(jl, jc)* & zdiff pabcu(jl, 17, jc) = pabcu(jl, 17, jcp1) + zuaer(jl, 4)*zduc(jl, jc)* & zdiff pabcu(jl, 18, jc) = pabcu(jl, 18, jcp1) + zuaer(jl, 5)*zduc(jl, jc)* & zdiff IF (type_trac=='repr') THEN #ifdef REPROBUS IF (ok_rtime2d) THEN pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + & zably(jl, 8, jc)*rch42d(jl, jc)/rco2*zphm6(jl)*zdiff pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + & zably(jl, 9, jc)*rch42d(jl, jc)/rco2*zpsm6(jl)*zdiff pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + & zably(jl, 8, jc)*rn2o2d(jl, jc)/rco2*zphn6(jl)*zdiff pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + & zably(jl, 9, jc)*rn2o2d(jl, jc)/rco2*zpsn6(jl)*zdiff pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + & zably(jl, 8, jc)*rcfc112d(jl, jc)/rco2*zdiff pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + & zably(jl, 8, jc)*rcfc122d(jl, jc)/rco2*zdiff ELSE ! Same calculation as for type_trac /= repr pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + & zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + & zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + & zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + & zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + & zably(jl, 8, jc)*rcfc11/rco2*zdiff pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + & zably(jl, 8, jc)*rcfc12/rco2*zdiff END IF #endif ELSE pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + & zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + & zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + & zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + & zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + & zably(jl, 8, jc)*rcfc11/rco2*zdiff pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + & zably(jl, 8, jc)*rcfc12/rco2*zdiff END IF END DO END DO END DO RETURN END SUBROUTINE lwu_lmdar4 SUBROUTINE lwbv_lmdar4(klim, pdp, pdt0, pemis, ppmb, ptl, ptave, pabcu, & pfluc, pbint, pbsui, pcts, pcntrb) USE dimphy IMPLICIT NONE include "raddimlw.h" include "YOMCST.h" ! PURPOSE. ! -------- ! TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE ! VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY ! SAVING ! METHOD. ! ------- ! 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. ! 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE ! BOUNDARIES. ! 3. COMPUTES THE CLEAR-SKY COOLING RATES. ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 89-07-14 ! MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE ! MEMORY) ! ----------------------------------------------------------------------- ! * ARGUMENTS: INTEGER klim REAL (KIND=8) pdp(kdlon, kflev) REAL (KIND=8) pdt0(kdlon) REAL (KIND=8) pemis(kdlon) REAL (KIND=8) ppmb(kdlon, kflev+1) REAL (KIND=8) ptl(kdlon, kflev+1) REAL (KIND=8) ptave(kdlon, kflev) REAL (KIND=8) pfluc(kdlon, 2, kflev+1) REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) REAL (KIND=8) pbint(kdlon, kflev+1) REAL (KIND=8) pbsui(kdlon) REAL (KIND=8) pcts(kdlon, kflev) REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! ------------------------------------------------------------------------- ! * LOCAL VARIABLES: REAL (KIND=8) zb(kdlon, ninter, kflev+1) REAL (KIND=8) zbsur(kdlon, ninter) REAL (KIND=8) zbtop(kdlon, ninter) REAL (KIND=8) zdbsl(kdlon, ninter, kflev*2) REAL (KIND=8) zga(kdlon, 8, 2, kflev) REAL (KIND=8) zgb(kdlon, 8, 2, kflev) REAL (KIND=8) zgasur(kdlon, 8, 2) REAL (KIND=8) zgbsur(kdlon, 8, 2) REAL (KIND=8) zgatop(kdlon, 8, 2) REAL (KIND=8) zgbtop(kdlon, 8, 2) INTEGER nuaer, ntraer ! ------------------------------------------------------------------ ! * COMPUTES PLANCK FUNCTIONS: CALL lwb_lmdar4(pdt0, ptave, ptl, zb, pbint, pbsui, zbsur, zbtop, zdbsl, & zga, zgb, zgasur, zgbsur, zgatop, zgbtop) ! ------------------------------------------------------------------ ! * PERFORMS THE VERTICAL INTEGRATION: nuaer = nua ntraer = ntra CALL lwv_lmdar4(nuaer, ntraer, klim, pabcu, zb, pbint, pbsui, zbsur, zbtop, & zdbsl, pemis, ppmb, ptave, zga, zgb, zgasur, zgbsur, zgatop, zgbtop, & pcntrb, pcts, pfluc) ! ------------------------------------------------------------------ RETURN END SUBROUTINE lwbv_lmdar4 SUBROUTINE lwc_lmdar4(klim, pcldld, pcldlu, pemis, pfluc, pbint, pbsuin, & pcts, pcntrb, pflux) USE dimphy IMPLICIT NONE include "radepsi.h" include "radopt.h" ! PURPOSE. ! -------- ! INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR ! RADIANCES ! EXPLICIT ARGUMENTS : ! -------------------- ! ==== INPUTS === ! PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION ! PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION ! PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION ! PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION ! PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE ! PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE ! PEMIS : (KDLON) ; SURFACE EMISSIVITY ! PFLUC ! ==== OUTPUTS === ! PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES : ! 1 ==> UPWARD FLUX TOTAL ! 2 ==> DOWNWARD FLUX TOTAL ! METHOD. ! ------- ! 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES ! 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER ! 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED ! CLOUDS ! REFERENCE. ! ---------- ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS ! AUTHOR. ! ------- ! JEAN-JACQUES MORCRETTE *ECMWF* ! MODIFICATIONS. ! -------------- ! ORIGINAL : 89-07-14 ! Voigt lines (loop 231 to 233) - JJM & PhD - 01/96 ! ----------------------------------------------------------------------- ! * ARGUMENTS: INTEGER klim REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) !CLEAR-SKY ENERGY EXCHANGE REAL (KIND=8) pcts(kdlon, kflev) ! CLEAR-SKY LAYER COOLING-TO-SPACE REAL (KIND=8) pcldld(kdlon, kflev) REAL (KIND=8) pcldlu(kdlon, kflev) REAL (KIND=8) pemis(kdlon) REAL (KIND=8) pflux(kdlon, 2, kflev+1) ! ----------------------------------------------------------------------- ! * LOCAL VARIABLES: INTEGER imx(kdlon), imxp(kdlon) REAL (KIND=8) zclear(kdlon), zcloud(kdlon), zdnf(kdlon, kflev+1, kflev+1), & zfd(kdlon), zfn10(kdlon), zfu(kdlon), zupf(kdlon, kflev+1, kflev+1) REAL (KIND=8) zclm(kdlon, kflev+1, kflev+1) INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1 INTEGER jk1, jk2, jkc, jkcp1, jcloud INTEGER imxm1, imxp1 REAL (KIND=8) zcfrac ! ------------------------------------------------------------------ ! * 1. INITIALIZATION ! -------------- imaxc = 0 DO jl = 1, kdlon imx(jl) = 0 imxp(jl) = 0 zcloud(jl) = 0. END DO ! * 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD ! ------------------------------------------- DO jk = 1, kflev DO jl = 1, kdlon imx1 = imx(jl) imx2 = jk IF (pcldlu(jl,jk)>zepsc) THEN imxp(jl) = imx2 ELSE imxp(jl) = imx1 END IF imaxc = max(imxp(jl), imaxc) imx(jl) = imxp(jl) END DO END DO ! GM******* imaxc = kflev ! GM******* DO jk = 1, kflev + 1 DO jl = 1, kdlon pflux(jl, 1, jk) = pfluc(jl, 1, jk) pflux(jl, 2, jk) = pfluc(jl, 2, jk) END DO END DO ! ------------------------------------------------------------------ ! * 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES ! --------------------------------------- IF (imaxc>0) THEN imxp1 = imaxc + 1 imxm1 = imaxc - 1 ! * 2.0 INITIALIZE TO CLEAR-SKY FLUXES ! ------------------------------ DO jk1 = 1, kflev + 1 DO jk2 = 1, kflev + 1 DO jl = 1, kdlon zupf(jl, jk2, jk1) = pfluc(jl, 1, jk1) zdnf(jl, jk2, jk1) = pfluc(jl, 2, jk1) END DO END DO END DO ! * 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD ! ---------------------------------------------- DO jkc = 1, imaxc jcloud = jkc jkcp1 = jcloud + 1 ! * 2.1.1 ABOVE THE CLOUD ! --------------- DO jk = jkcp1, kflev + 1 jkm1 = jk - 1 DO jl = 1, kdlon zfu(jl) = 0. END DO IF (jk>jkcp1) THEN DO jkj = jkcp1, jkm1 DO jl = 1, kdlon zfu(jl) = zfu(jl) + pcntrb(jl, jk, jkj) END DO END DO END IF DO jl = 1, kdlon zupf(jl, jkcp1, jk) = pbint(jl, jk) - zfu(jl) END DO END DO ! * 2.1.2 BELOW THE CLOUD ! --------------- DO jk = 1, jcloud jkp1 = jk + 1 DO jl = 1, kdlon zfd(jl) = 0. END DO IF (jk