--- trunk/phylmd/Radlwsw/sw1s.f 2013/11/15 18:45:49 76 +++ trunk/phylmd/Radlwsw/sw1s.f90 2014/03/05 14:38:41 81 @@ -1,239 +1,220 @@ - SUBROUTINE SW1S ( KNU - S , PAER , flag_aer, tauae, pizae, cgae - S , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW - S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD - S , PFD , PFU) - use dimens_m - use dimphy - use raddim - IMPLICIT none -C -C ------------------------------------------------------------------ -C PURPOSE. -C -------- -C -C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO -C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). -C -C METHOD. -C ------- -C -C 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO -C CONTINUUM SCATTERING -C 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION -C -C REFERENCE. -C ---------- -C -C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT -C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) -C -C AUTHOR. -C ------- -C JEAN-JACQUES MORCRETTE *ECMWF* -C -C MODIFICATIONS. -C -------------- -C ORIGINAL : 89-07-14 -C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO -C ------------------------------------------------------------------ -C -C* ARGUMENTS: -C - INTEGER KNU -c-OB - double precision flag_aer - double precision tauae(kdlon,kflev,2) - double precision pizae(kdlon,kflev,2) - double precision cgae(kdlon,kflev,2) - DOUBLE PRECISION PAER(KDLON,KFLEV,5) - DOUBLE PRECISION PALBD(KDLON,2) - DOUBLE PRECISION PALBP(KDLON,2) - DOUBLE PRECISION PCG(KDLON,2,KFLEV) - DOUBLE PRECISION PCLD(KDLON,KFLEV) - DOUBLE PRECISION PCLDSW(KDLON,KFLEV) - DOUBLE PRECISION PCLEAR(KDLON) - DOUBLE PRECISION PDSIG(KDLON,KFLEV) - DOUBLE PRECISION POMEGA(KDLON,2,KFLEV) - DOUBLE PRECISION POZ(KDLON,KFLEV) - DOUBLE PRECISION PRMU(KDLON) - DOUBLE PRECISION PSEC(KDLON) - DOUBLE PRECISION PTAU(KDLON,2,KFLEV) - DOUBLE PRECISION PUD(KDLON,5,KFLEV+1) -C - DOUBLE PRECISION PFD(KDLON,KFLEV+1) - DOUBLE PRECISION PFU(KDLON,KFLEV+1) -C -C* LOCAL VARIABLES: -C - INTEGER IIND(4) -C - DOUBLE PRECISION ZCGAZ(KDLON,KFLEV) - DOUBLE PRECISION ZDIFF(KDLON) - DOUBLE PRECISION ZDIRF(KDLON) - DOUBLE PRECISION ZPIZAZ(KDLON,KFLEV) - DOUBLE PRECISION ZRAYL(KDLON) - DOUBLE PRECISION ZRAY1(KDLON,KFLEV+1) - DOUBLE PRECISION ZRAY2(KDLON,KFLEV+1) - DOUBLE PRECISION ZREFZ(KDLON,2,KFLEV+1) - DOUBLE PRECISION ZRJ(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRJ0(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRK(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRK0(KDLON,6,KFLEV+1) - DOUBLE PRECISION ZRMUE(KDLON,KFLEV+1) - DOUBLE PRECISION ZRMU0(KDLON,KFLEV+1) - DOUBLE PRECISION ZR(KDLON,4) - DOUBLE PRECISION ZTAUAZ(KDLON,KFLEV) - DOUBLE PRECISION ZTRA1(KDLON,KFLEV+1) - DOUBLE PRECISION ZTRA2(KDLON,KFLEV+1) - DOUBLE PRECISION ZW(KDLON,4) -C - INTEGER jl, jk, k, jaj, ikm1, ikl -c -c Prescribed Data: -c - DOUBLE PRECISION RSUN(2) - SAVE RSUN - DOUBLE PRECISION RRAY(2,6) - SAVE RRAY - DATA RSUN(1) / 0.441676 / - DATA RSUN(2) / 0.558324 / - DATA (RRAY(1,K),K=1,6) / - S .428937E-01, .890743E+00,-.288555E+01, - S .522744E+01,-.469173E+01, .161645E+01/ - DATA (RRAY(2,K),K=1,6) / - S .697200E-02, .173297E-01,-.850903E-01, - S .248261E+00,-.302031E+00, .129662E+00/ -C ------------------------------------------------------------------ -C -C* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON) -C ----------------------- ------------------ -C - 100 CONTINUE -C -C -C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING -C ----------------------------------------- -C - 110 CONTINUE -C - DO 111 JL = 1, KDLON - ZRAYL(JL) = RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL) - S * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL) - S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) )))) - 111 CONTINUE -C -C -C ------------------------------------------------------------------ -C -C* 2. CONTINUUM SCATTERING CALCULATIONS -C --------------------------------- -C - 200 CONTINUE -C -C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN -C -------------------------------- -C - 210 CONTINUE -C - CALL SWCLR ( KNU - S , PAER , flag_aer, tauae, pizae, cgae - S , PALBP , PDSIG , ZRAYL, PSEC - S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 - S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) -C -C -C* 2.2 CLOUDY FRACTION OF THE COLUMN -C ----------------------------- -C - 220 CONTINUE -C - CALL SWR ( KNU - S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL - S , PSEC ,PTAU - S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE - S , ZTAUAZ,ZTRA1 ,ZTRA2) -C -C -C ------------------------------------------------------------------ -C -C* 3. OZONE ABSORPTION -C ---------------- -C - 300 CONTINUE -C - IIND(1)=1 - IIND(2)=3 - IIND(3)=1 - IIND(4)=3 -C -C -C* 3.1 DOWNWARD FLUXES -C --------------- -C - 310 CONTINUE -C - JAJ = 2 -C - DO 311 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) - S + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU) - 311 CONTINUE - DO 314 JK = 1 , KFLEV - IKL = KFLEV+1-JK - DO 312 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) - 312 CONTINUE -C - CALL SWTT1(KNU, 4, IIND, ZW, ZR) -C - DO 313 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) - S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) - 313 CONTINUE - 314 CONTINUE -C -C -C* 3.2 UPWARD FLUXES -C ------------- -C - 320 CONTINUE -C - DO 325 JL = 1, KDLON - PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU) - S + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU)) - S * RSUN(KNU) - 325 CONTINUE -C - DO 328 JK = 2 , KFLEV+1 - IKM1=JK-1 - DO 326 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 - 326 CONTINUE -C - CALL SWTT1(KNU, 4, IIND, ZW, ZR) -C - DO 327 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) - S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) - 327 CONTINUE - 328 CONTINUE -C -C ------------------------------------------------------------------ -C - RETURN - END +SUBROUTINE sw1s(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, pcg, & + pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, pfd, & + pfu) + USE dimens_m + USE dimphy + USE raddim + 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 + DOUBLE PRECISION flag_aer + DOUBLE PRECISION tauae(kdlon, kflev, 2) + DOUBLE PRECISION pizae(kdlon, kflev, 2) + DOUBLE PRECISION cgae(kdlon, kflev, 2) + DOUBLE PRECISION paer(kdlon, kflev, 5) + DOUBLE PRECISION palbd(kdlon, 2) + DOUBLE PRECISION palbp(kdlon, 2) + DOUBLE PRECISION pcg(kdlon, 2, kflev) + DOUBLE PRECISION pcld(kdlon, kflev) + DOUBLE PRECISION pcldsw(kdlon, kflev) + DOUBLE PRECISION pclear(kdlon) + DOUBLE PRECISION pdsig(kdlon, kflev) + DOUBLE PRECISION pomega(kdlon, 2, kflev) + DOUBLE PRECISION poz(kdlon, kflev) + DOUBLE PRECISION prmu(kdlon) + DOUBLE PRECISION psec(kdlon) + DOUBLE PRECISION ptau(kdlon, 2, kflev) + DOUBLE PRECISION pud(kdlon, 5, kflev+1) + + DOUBLE PRECISION pfd(kdlon, kflev+1) + DOUBLE PRECISION pfu(kdlon, kflev+1) + + ! * LOCAL VARIABLES: + + INTEGER iind(4) + + DOUBLE PRECISION zcgaz(kdlon, kflev) + DOUBLE PRECISION zdiff(kdlon) + DOUBLE PRECISION zdirf(kdlon) + DOUBLE PRECISION zpizaz(kdlon, kflev) + DOUBLE PRECISION zrayl(kdlon) + DOUBLE PRECISION zray1(kdlon, kflev+1) + DOUBLE PRECISION zray2(kdlon, kflev+1) + DOUBLE PRECISION zrefz(kdlon, 2, kflev+1) + DOUBLE PRECISION zrj(kdlon, 6, kflev+1) + DOUBLE PRECISION zrj0(kdlon, 6, kflev+1) + DOUBLE PRECISION zrk(kdlon, 6, kflev+1) + DOUBLE PRECISION zrk0(kdlon, 6, kflev+1) + DOUBLE PRECISION zrmue(kdlon, kflev+1) + DOUBLE PRECISION zrmu0(kdlon, kflev+1) + DOUBLE PRECISION zr(kdlon, 4) + DOUBLE PRECISION ztauaz(kdlon, kflev) + DOUBLE PRECISION ztra1(kdlon, kflev+1) + DOUBLE PRECISION ztra2(kdlon, kflev+1) + DOUBLE PRECISION zw(kdlon, 4) + + INTEGER jl, jk, k, jaj, ikm1, ikl + + ! Prescribed Data: + + DOUBLE PRECISION rsun(2) + SAVE rsun + DOUBLE PRECISION rray(2, 6) + SAVE rray + DATA rsun(1)/0.441676/ + DATA rsun(2)/0.558324/ + DATA (rray(1,k), k=1, 6)/.428937E-01, .890743E+00, -.288555E+01, & + .522744E+01, -.469173E+01, .161645E+01/ + DATA (rray(2,k), k=1, 6)/.697200E-02, .173297E-01, -.850903E-01, & + .248261E+00, -.302031E+00, .129662E+00/ + ! ------------------------------------------------------------------ + + ! * 1. 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(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, & + psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, & + ztra1, ztra2) + + + ! * 2.2 CLOUDY FRACTION OF THE COLUMN + ! ----------------------------- + + + CALL swr(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, zcgaz, & + zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2) + + + ! ------------------------------------------------------------------ + + ! * 3. 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(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(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