phylmd/Radlwsw/sw2s.f

module sw2s_m

  IMPLICIT NONE

contains

  SUBROUTINE sw2s(knu, paki, palbd, palbp, pcg, pcld, pclear, pdsig, pomega, &
       poz, prmu, psec, ptau, pud, pwv, pqs, pfdown, pfup)
    
    USE dimensions
    USE dimphy
    USE raddim
    USE radepsi
    use swclr_m, only: swclr
    use swde_m, only: swde
    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
    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, palbp, pdsig, zrayl, psec, zpizaz, zray1, zray2, zrefz, &
         zrj0, zrk0, zrmu0, ztauaz, ztra1, ztra2)


    ! *         2.2   CLOUDY FRACTION OF THE COLUMN
    ! -----------------------------


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