! 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 lmdz_print_control, ONLY: lunout USE lmdz_clesphys USE lmdz_yomcst IMPLICIT NONE ! ------------------------------------------------------------------ ! 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) 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 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 USE lmdz_clesphys, ONLY: RCO2 USE lmdz_yomcst IMPLICIT NONE include "radepsi.h" include "radopt.h" ! * ARGUMENTS: REAL (KIND = 8) psct 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 ! ------------------------------------------------------------------ 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 USE lmdz_print_control, ONLY: lunout #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 ! ------------------------------------------------------------------ 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 ! ------------------------------------------------------------------ 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 ! ------------------------------------------------------------------ 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 ! ------------------------------------------------------------------ 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 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 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 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 lmdz_print_control, ONLY: lunout ! 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) USE lmdz_clesphys, ONLY: rco2, rch4, rn2o, rcfc11, rcfc12 USE lmdz_yomcst IMPLICIT NONE include "raddimlw.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 ! ----------------------------------------------------------------------- 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 ! ------------------------------------------------------------------ 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 ! IM ctes ds clesphys.h ! REAL(KIND=8) RCO2 ! REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12 USE lmdz_clesphys, ONLY: rco2, rch4, rn2o, rcfc11, rcfc12 USE lmdz_yomcst IMPLICIT NONE include "raddimlw.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: 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 END SUBROUTINE lwu_lmdar4 SUBROUTINE lwbv_lmdar4(klim, pdp, pdt0, pemis, ppmb, ptl, ptave, pabcu, & pfluc, pbint, pbsui, pcts, pcntrb) USE dimphy USE lmdz_yomcst IMPLICIT NONE include "raddimlw.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) ! ------------------------------------------------------------------ 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