phylmd/Radlwsw/sw2s.f

module sw2s_m

  IMPLICIT NONE

contains

  SUBROUTINE sw2s(knu, flag_aer, tauae, pizae, cgae, paki, palbd, palbp, &
       pcg, pcld, pclear, pdsig, pomega, poz, prmu, psec, ptau, pud, &
       pwv, pqs, pfdown, pfup)
    USE dimens_m
    USE dimphy
    USE raddim
    USE radepsi
    use swclr_m, only: swclr
    use swr_m, only: swr

    ! ------------------------------------------------------------------
    ! 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
    DOUBLE PRECISION flag_aer
    DOUBLE PRECISION tauae(kdlon, kflev, 2)
    DOUBLE PRECISION pizae(kdlon, kflev, 2)
    DOUBLE PRECISION cgae(kdlon, kflev, 2)
    DOUBLE PRECISION paki(kdlon, 2)
    DOUBLE PRECISION palbd(kdlon, 2)
    DOUBLE PRECISION palbp(kdlon, 2)
    DOUBLE PRECISION pcg(kdlon, 2, kflev)
    DOUBLE PRECISION pcld(kdlon, kflev)
    DOUBLE PRECISION pclear(kdlon)
    DOUBLE PRECISION pdsig(kdlon, kflev)
    DOUBLE PRECISION pomega(kdlon, 2, kflev)
    DOUBLE PRECISION poz(kdlon, kflev)
    DOUBLE PRECISION pqs(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 pwv(kdlon, kflev)

    DOUBLE PRECISION pfdown(kdlon, kflev+1)
    DOUBLE PRECISION pfup(kdlon, kflev+1)

    ! * LOCAL VARIABLES:

    INTEGER iind2(2), iind3(3)
    DOUBLE PRECISION zcgaz(kdlon, kflev)
    DOUBLE PRECISION zfd(kdlon, kflev+1)
    DOUBLE PRECISION zfu(kdlon, kflev+1)
    DOUBLE PRECISION zg(kdlon)
    DOUBLE PRECISION zgg(kdlon)
    DOUBLE PRECISION zpizaz(kdlon, kflev)
    DOUBLE PRECISION zrayl(kdlon)
    DOUBLE PRECISION zray1(kdlon, kflev+1)
    DOUBLE PRECISION zray2(kdlon, kflev+1)
    DOUBLE PRECISION zref(kdlon)
    DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
    DOUBLE PRECISION zre1(kdlon)
    DOUBLE PRECISION zre2(kdlon)
    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 zrl(kdlon, 8)
    DOUBLE PRECISION zrmue(kdlon, kflev+1)
    DOUBLE PRECISION zrmu0(kdlon, kflev+1)
    DOUBLE PRECISION zrmuz(kdlon)
    DOUBLE PRECISION zrneb(kdlon)
    DOUBLE PRECISION zr1(kdlon)
    DOUBLE PRECISION zr2(kdlon, 2)
    DOUBLE PRECISION zr3(kdlon, 3)
    DOUBLE PRECISION zr4(kdlon)
    DOUBLE PRECISION zr21(kdlon)
    DOUBLE PRECISION zr22(kdlon)
    DOUBLE PRECISION zs(kdlon)
    DOUBLE PRECISION ztauaz(kdlon, kflev)
    DOUBLE PRECISION zto1(kdlon)
    DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
    DOUBLE PRECISION ztra1(kdlon, kflev+1)
    DOUBLE PRECISION ztra2(kdlon, kflev+1)
    DOUBLE PRECISION ztr1(kdlon)
    DOUBLE PRECISION ztr2(kdlon)
    DOUBLE PRECISION zw(kdlon)
    DOUBLE PRECISION zw1(kdlon)
    DOUBLE PRECISION zw2(kdlon, 2)
    DOUBLE PRECISION zw3(kdlon, 3)
    DOUBLE PRECISION zw4(kdlon)
    DOUBLE PRECISION zw5(kdlon)

    INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
    INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
    DOUBLE PRECISION zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11

    ! * Prescribed Data:

    DOUBLE PRECISION rsun(2)
    SAVE rsun
    DOUBLE PRECISION rray(2, 6)
    SAVE rray
    DATA rsun(1)/0.441676d0/
    DATA rsun(2)/0.558324d0/
    DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
         .522744d+01, -.469173d+01, .161645d+01/
    DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
         .248261d+00, -.302031d+00, .129662d+00/

    ! ------------------------------------------------------------------

    ! *         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(knu, 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, pomega, 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(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(knu, 2, iind2, zw2, zr2)

             DO jl = 1, kdlon
                zrl(jl, jkki) = zr2(jl, 1)
                zrl(jl, jkkp4) = zr2(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(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(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(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(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

end module sw2s_m
1	guez	178	module sw2s_m
2
3	guez	81	IMPLICIT NONE
4	guez	24
5	guez	178	contains
6	guez	81
7	guez	178	SUBROUTINE sw2s(knu, flag_aer, tauae, pizae, cgae, paki, palbd, palbp, &
8			pcg, pcld, pclear, pdsig, pomega, poz, prmu, psec, ptau, pud, &
9			pwv, pqs, pfdown, pfup)
10			USE dimens_m
11			USE dimphy
12			USE raddim
13			USE radepsi
14			use swclr_m, only: swclr
15			use swr_m, only: swr
16	guez	81
17	guez	178	! ------------------------------------------------------------------
18			! PURPOSE.
19			! --------
20	guez	81
21	guez	178	! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
22			! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
23	guez	81
24	guez	178	! METHOD.
25			! -------
26	guez	81
27	guez	178	! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
28			! CONTINUUM SCATTERING
29			! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
30			! A GREY MOLECULAR ABSORPTION
31			! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
32			! OF ABSORBERS
33			! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
34			! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
35	guez	81
36	guez	178	! REFERENCE.
37			! ----------
38	guez	81
39	guez	178	! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
40			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
41	guez	81
42	guez	178	! AUTHOR.
43			! -------
44			! JEAN-JACQUES MORCRETTE ECMWF
45	guez	81
46	guez	178	! MODIFICATIONS.
47			! --------------
48			! ORIGINAL : 89-07-14
49			! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
50			! ------------------------------------------------------------------
51			! * ARGUMENTS:
52	guez	81
53	guez	178	INTEGER knu
54			! -OB
55			DOUBLE PRECISION flag_aer
56			DOUBLE PRECISION tauae(kdlon, kflev, 2)
57			DOUBLE PRECISION pizae(kdlon, kflev, 2)
58			DOUBLE PRECISION cgae(kdlon, kflev, 2)
59			DOUBLE PRECISION paki(kdlon, 2)
60			DOUBLE PRECISION palbd(kdlon, 2)
61			DOUBLE PRECISION palbp(kdlon, 2)
62			DOUBLE PRECISION pcg(kdlon, 2, kflev)
63			DOUBLE PRECISION pcld(kdlon, kflev)
64			DOUBLE PRECISION pclear(kdlon)
65			DOUBLE PRECISION pdsig(kdlon, kflev)
66			DOUBLE PRECISION pomega(kdlon, 2, kflev)
67			DOUBLE PRECISION poz(kdlon, kflev)
68			DOUBLE PRECISION pqs(kdlon, kflev)
69			DOUBLE PRECISION prmu(kdlon)
70			DOUBLE PRECISION psec(kdlon)
71			DOUBLE PRECISION ptau(kdlon, 2, kflev)
72			DOUBLE PRECISION pud(kdlon, 5, kflev+1)
73			DOUBLE PRECISION pwv(kdlon, kflev)
74	guez	81
75	guez	178	DOUBLE PRECISION pfdown(kdlon, kflev+1)
76			DOUBLE PRECISION pfup(kdlon, kflev+1)
77	guez	81
78	guez	178	! * LOCAL VARIABLES:
79	guez	81
80	guez	178	INTEGER iind2(2), iind3(3)
81			DOUBLE PRECISION zcgaz(kdlon, kflev)
82			DOUBLE PRECISION zfd(kdlon, kflev+1)
83			DOUBLE PRECISION zfu(kdlon, kflev+1)
84			DOUBLE PRECISION zg(kdlon)
85			DOUBLE PRECISION zgg(kdlon)
86			DOUBLE PRECISION zpizaz(kdlon, kflev)
87			DOUBLE PRECISION zrayl(kdlon)
88			DOUBLE PRECISION zray1(kdlon, kflev+1)
89			DOUBLE PRECISION zray2(kdlon, kflev+1)
90			DOUBLE PRECISION zref(kdlon)
91			DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
92			DOUBLE PRECISION zre1(kdlon)
93			DOUBLE PRECISION zre2(kdlon)
94			DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
95			DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
96			DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
97			DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
98			DOUBLE PRECISION zrl(kdlon, 8)
99			DOUBLE PRECISION zrmue(kdlon, kflev+1)
100			DOUBLE PRECISION zrmu0(kdlon, kflev+1)
101			DOUBLE PRECISION zrmuz(kdlon)
102			DOUBLE PRECISION zrneb(kdlon)
103			DOUBLE PRECISION zr1(kdlon)
104			DOUBLE PRECISION zr2(kdlon, 2)
105			DOUBLE PRECISION zr3(kdlon, 3)
106			DOUBLE PRECISION zr4(kdlon)
107			DOUBLE PRECISION zr21(kdlon)
108			DOUBLE PRECISION zr22(kdlon)
109			DOUBLE PRECISION zs(kdlon)
110			DOUBLE PRECISION ztauaz(kdlon, kflev)
111			DOUBLE PRECISION zto1(kdlon)
112			DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
113			DOUBLE PRECISION ztra1(kdlon, kflev+1)
114			DOUBLE PRECISION ztra2(kdlon, kflev+1)
115			DOUBLE PRECISION ztr1(kdlon)
116			DOUBLE PRECISION ztr2(kdlon)
117			DOUBLE PRECISION zw(kdlon)
118			DOUBLE PRECISION zw1(kdlon)
119			DOUBLE PRECISION zw2(kdlon, 2)
120			DOUBLE PRECISION zw3(kdlon, 3)
121			DOUBLE PRECISION zw4(kdlon)
122			DOUBLE PRECISION zw5(kdlon)
123	guez	81
124	guez	178	INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
125			INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
126			DOUBLE PRECISION zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11
127	guez	81
128	guez	178	! * Prescribed Data:
129	guez	81
130	guez	178	DOUBLE PRECISION rsun(2)
131			SAVE rsun
132			DOUBLE PRECISION rray(2, 6)
133			SAVE rray
134			DATA rsun(1)/0.441676d0/
135			DATA rsun(2)/0.558324d0/
136			DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
137			.522744d+01, -.469173d+01, .161645d+01/
138			DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
139			.248261d+00, -.302031d+00, .129662d+00/
140	guez	81
141	guez	178	! ------------------------------------------------------------------
142	guez	81
143	guez	178	! * 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
144			! -------------------------------------------
145	guez	81
146
147
148	guez	178	! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
149			! -----------------------------------------
150	guez	81
151
152	guez	178	DO jl = 1, kdlon
153			zrmum1 = 1. - prmu(jl)
154			zrayl(jl) = rray(knu, 1) + zrmum1(rray(knu,2)+zrmum1(rray(knu, &
155			3)+zrmum1(rray(knu,4)+zrmum1(rray(knu,5)+zrmum1*rray(knu,6)))))
156			END DO
157	guez	81
158
159	guez	178	! ------------------------------------------------------------------
160	guez	81
161	guez	178	! * 2. CONTINUUM SCATTERING CALCULATIONS
162			! ---------------------------------
163	guez	81
164
165	guez	178	! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN
166			! --------------------------------
167	guez	81
168
169	guez	178	CALL swclr(knu, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &
170			psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &
171			ztra1, ztra2)
172	guez	81
173
174	guez	178	! * 2.2 CLOUDY FRACTION OF THE COLUMN
175			! -----------------------------
176	guez	81
177
178	guez	178	CALL swr(knu, palbd, pcg, pcld, pomega, psec, ptau, zcgaz, &
179			zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
180	guez	81
181
182	guez	178	! ------------------------------------------------------------------
183	guez	81
184	guez	178	! * 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
185			! ------------------------------------------------------
186	guez	81
187
188	guez	178	jn = 2
189	guez	81
190	guez	178	DO jabs = 1, 2
191	guez	81
192
193	guez	178	! * 3.1 SURFACE CONDITIONS
194			! ------------------
195	guez	81
196
197	guez	178	DO jl = 1, kdlon
198			zrefz(jl, 2, 1) = palbd(jl, knu)
199			zrefz(jl, 1, 1) = palbd(jl, knu)
200			END DO
201	guez	81
202
203	guez	178	! * 3.2 INTRODUCING CLOUD EFFECTS
204			! -------------------------
205	guez	81
206
207	guez	178	DO jk = 2, kflev + 1
208			jkm1 = jk - 1
209			ikl = kflev + 1 - jkm1
210			DO jl = 1, kdlon
211			zrneb(jl) = pcld(jl, jkm1)
212			IF (jabs==1 .AND. zrneb(jl)>2.*zeelog) THEN
213			zwh2o = max(pwv(jl,jkm1), zeelog)
214			zcneb = max(zeelog, min(zrneb(jl),1.-zeelog))
215			zbb = pud(jl, jabs, jkm1)*pqs(jl, jkm1)/zwh2o
216			zaa = max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.-zcneb), zeelog)
217			ELSE
218			zaa = pud(jl, jabs, jkm1)
219			zbb = zaa
220			END IF
221			zrki = paki(jl, jabs)
222			zs(jl) = exp(-zrkizaa1.66)
223			zg(jl) = exp(-zrki*zaa/zrmue(jl,jk))
224			ztr1(jl) = 0.
225			zre1(jl) = 0.
226			ztr2(jl) = 0.
227			zre2(jl) = 0.
228	guez	81
229	guez	178	zw(jl) = pomega(jl, knu, jkm1)
230			zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, &
231			jkm1) + zbb*zrki
232	guez	81
233	guez	178	zr21(jl) = ptau(jl, knu, jkm1) + ztauaz(jl, jkm1)
234			zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
235			zgg(jl) = zr22(jl)pcg(jl, knu, jkm1) + (1.-zr22(jl))zcgaz(jl, jkm1)
236			zw(jl) = zr21(jl)/zto1(jl)
237			zref(jl) = zrefz(jl, 1, jkm1)
238			zrmuz(jl) = zrmue(jl, jk)
239			END DO
240	guez	81
241	guez	178	CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
242	guez	81
243	guez	178	DO jl = 1, kdlon
244	guez	81
245	guez	178	zrefz(jl, 2, jk) = (1.-zrneb(jl))(zray1(jl,jkm1)+zrefz(jl,2,jkm1) &
246			ztra1(jl,jkm1)ztra2(jl,jkm1))zg(jl)zs(jl) + zrneb(jl)zre1(jl)
247	guez	81
248	guez	178	ztr(jl, 2, jkm1) = zrneb(jl)ztr1(jl) + (ztra1(jl,jkm1))zg(jl)*(1.- &
249			zrneb(jl))
250	guez	81
251	guez	178	zrefz(jl, 1, jk) = (1.-zrneb(jl))(zray1(jl,jkm1)+zrefz(jl,1,jkm1) &
252			ztra1(jl,jkm1)ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)zrefz(jl,1, &
253			jkm1)))zg(jl)zs(jl) + zrneb(jl)*zre2(jl)
254	guez	81
255	guez	178	ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, &
256			jkm1)zrefz(jl,1,jkm1)))zg(jl)*(1.-zrneb(jl))
257	guez	81
258	guez	178	END DO
259			END DO
260	guez	81
261	guez	178	! * 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
262			! -------------------------------------------------
263	guez	81
264
265	guez	178	DO jref = 1, 2
266	guez	81
267	guez	178	jn = jn + 1
268
269			DO jl = 1, kdlon
270			zrj(jl, jn, kflev+1) = 1.
271			zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1)
272			END DO
273
274			DO jk = 1, kflev
275			jkl = kflev + 1 - jk
276			jklp1 = jkl + 1
277			DO jl = 1, kdlon
278			zre11 = zrj(jl, jn, jklp1)*ztr(jl, jref, jkl)
279			zrj(jl, jn, jkl) = zre11
280			zrk(jl, jn, jkl) = zre11*zrefz(jl, jref, jkl)
281			END DO
282			END DO
283			END DO
284	guez	81	END DO
285
286
287	guez	178	! ------------------------------------------------------------------
288	guez	81
289	guez	178	! * 4. INVERT GREY AND CONTINUUM FLUXES
290			! --------------------------------
291	guez	81
292
293
294	guez	178	! * 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
295			! ---------------------------------------------
296	guez	81
297
298	guez	178	DO jk = 1, kflev + 1
299			DO jaj = 1, 5, 2
300			jajp = jaj + 1
301			DO jl = 1, kdlon
302			zrj(jl, jaj, jk) = zrj(jl, jaj, jk) - zrj(jl, jajp, jk)
303			zrk(jl, jaj, jk) = zrk(jl, jaj, jk) - zrk(jl, jajp, jk)
304			zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
305			zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
306			END DO
307			END DO
308	guez	81	END DO
309
310	guez	178	DO jk = 1, kflev + 1
311			DO jaj = 2, 6, 2
312			DO jl = 1, kdlon
313			zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
314			zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
315			END DO
316			END DO
317	guez	81	END DO
318
319	guez	178	! * 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
320			! ---------------------------------------------
321	guez	81
322
323	guez	178	DO jk = 1, kflev + 1
324			jkki = 1
325			DO jaj = 1, 2
326			iind2(1) = jaj
327			iind2(2) = jaj
328			DO jn = 1, 2
329			jn2j = jn + 2*jaj
330			jkkp4 = jkki + 4
331	guez	81
332	guez	178	! * 4.2.1 EFFECTIVE ABSORBER AMOUNTS
333			! --------------------------
334	guez	81
335
336	guez	178	DO jl = 1, kdlon
337			zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj)
338			zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj)
339			END DO
340	guez	81
341	guez	178	! * 4.2.2 TRANSMISSION FUNCTION
342			! ---------------------
343	guez	81
344
345	guez	178	CALL swtt1(knu, 2, iind2, zw2, zr2)
346	guez	81
347	guez	178	DO jl = 1, kdlon
348			zrl(jl, jkki) = zr2(jl, 1)
349			zrl(jl, jkkp4) = zr2(jl, 2)
350			END DO
351	guez	81
352	guez	178	jkki = jkki + 1
353			END DO
354			END DO
355	guez	81
356	guez	178	! * 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
357			! ------------------------------------------------------
358	guez	81
359
360	guez	178	DO jl = 1, kdlon
361			pfdown(jl, jk) = zrj(jl, 1, jk)zrl(jl, 1)zrl(jl, 3) + &
362			zrj(jl, 2, jk)zrl(jl, 2)zrl(jl, 4)
363			pfup(jl, jk) = zrk(jl, 1, jk)zrl(jl, 5)zrl(jl, 7) + &
364			zrk(jl, 2, jk)zrl(jl, 6)zrl(jl, 8)
365			END DO
366	guez	81	END DO
367
368
369	guez	178	! ------------------------------------------------------------------
370	guez	81
371	guez	178	! * 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
372			! ----------------------------------------
373	guez	81
374
375
376	guez	178	! * 5.1 DOWNWARD FLUXES
377			! ---------------
378	guez	81
379
380	guez	178	jaj = 2
381			iind3(1) = 1
382			iind3(2) = 2
383			iind3(3) = 3
384	guez	81
385			DO jl = 1, kdlon
386	guez	178	zw3(jl, 1) = 0.
387			zw3(jl, 2) = 0.
388			zw3(jl, 3) = 0.
389			zw4(jl) = 0.
390			zw5(jl) = 0.
391			zr4(jl) = 1.
392			zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1)
393	guez	81	END DO
394	guez	178	DO jk = 1, kflev
395			ikl = kflev + 1 - jk
396			DO jl = 1, kdlon
397			zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
398			zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl)
399			zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl)
400			zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl)
401			zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl)
402			END DO
403	guez	81
404	guez	178	CALL swtt1(knu, 3, iind3, zw3, zr3)
405	guez	81
406	guez	178	DO jl = 1, kdlon
407			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
408			zfd(jl, ikl) = zr3(jl, 1)zr3(jl, 2)zr3(jl, 3)zr4(jl) &
409			zrj0(jl, jaj, ikl)
410			END DO
411	guez	81	END DO
412
413
414	guez	178	! * 5.2 UPWARD FLUXES
415			! -------------
416	guez	81
417
418			DO jl = 1, kdlon
419	guez	178	zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu)
420	guez	81	END DO
421
422	guez	178	DO jk = 2, kflev + 1
423			ikm1 = jk - 1
424			DO jl = 1, kdlon
425			zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66
426			zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66
427			zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66
428			zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
429			zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
430			END DO
431	guez	81
432	guez	178	CALL swtt1(knu, 3, iind3, zw3, zr3)
433
434			DO jl = 1, kdlon
435			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
436			zfu(jl, jk) = zr3(jl, 1)zr3(jl, 2)zr3(jl, 3)zr4(jl) &
437			zrk0(jl, jaj, jk)
438			END DO
439	guez	81	END DO
440
441
442	guez	178	! ------------------------------------------------------------------
443	guez	81
444	guez	178	! * 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
445			! --------------------------------------------------
446	guez	81
447	guez	178	iabs = 3
448	guez	81
449	guez	178	! * 6.1 DOWNWARD FLUXES
450			! ---------------
451	guez	81
452			DO jl = 1, kdlon
453	guez	178	zw1(jl) = 0.
454			zw4(jl) = 0.
455			zw5(jl) = 0.
456			zr1(jl) = 0.
457			pfdown(jl, kflev+1) = ((1.-pclear(jl))pfdown(jl,kflev+1)+pclear(jl)zfd( &
458			jl,kflev+1))*rsun(knu)
459	guez	81	END DO
460
461	guez	178	DO jk = 1, kflev
462			ikl = kflev + 1 - jk
463			DO jl = 1, kdlon
464			zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl)
465			zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl)
466			zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl)
467			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
468			END DO
469	guez	81
470	guez	178	CALL swtt(knu, iabs, zw1, zr1)
471
472			DO jl = 1, kdlon
473			pfdown(jl, ikl) = ((1.-pclear(jl))zr1(jl)zr4(jl)*pfdown(jl,ikl)+ &
474			pclear(jl)zfd(jl,ikl))rsun(knu)
475			END DO
476	guez	81	END DO
477
478
479	guez	178	! * 6.2 UPWARD FLUXES
480			! -------------
481	guez	81
482			DO jl = 1, kdlon
483	guez	178	pfup(jl, 1) = ((1.-pclear(jl))zr1(jl)zr4(jl)pfup(jl,1)+pclear(jl)zfu( &
484			jl,1))*rsun(knu)
485	guez	81	END DO
486
487	guez	178	DO jk = 2, kflev + 1
488			ikm1 = jk - 1
489			DO jl = 1, kdlon
490			zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66
491			zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
492			zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
493			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
494			END DO
495	guez	81
496	guez	178	CALL swtt(knu, iabs, zw1, zr1)
497
498			DO jl = 1, kdlon
499			pfup(jl, jk) = ((1.-pclear(jl))zr1(jl)zr4(jl)pfup(jl,jk)+pclear(jl) &
500			zfu(jl,jk))*rsun(knu)
501			END DO
502	guez	81	END DO
503
504	guez	178	END SUBROUTINE sw2s
505	guez	81
506	guez	178	end module sw2s_m