phylmd/Radlwsw/swr.f

module swr_m

  IMPLICIT NONE

contains

  SUBROUTINE swr(knu, palbd, pcg, pcld, pomega, psec, ptau, &
       pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, &
       ptra2)
    USE dimens_m
    USE dimphy
    USE raddim
    USE radepsi
    USE radopt

    ! ------------------------------------------------------------------
    ! 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
    DOUBLE PRECISION palbd(kdlon, 2)
    DOUBLE PRECISION pcg(kdlon, 2, kflev)
    DOUBLE PRECISION pcld(kdlon, kflev)
    DOUBLE PRECISION pomega(kdlon, 2, kflev)
    DOUBLE PRECISION psec(kdlon)
    DOUBLE PRECISION ptau(kdlon, 2, kflev)

    DOUBLE PRECISION pray1(kdlon, kflev+1)
    DOUBLE PRECISION pray2(kdlon, kflev+1)
    DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
    DOUBLE PRECISION prj(kdlon, 6, kflev+1)
    DOUBLE PRECISION prk(kdlon, 6, kflev+1)
    DOUBLE PRECISION prmue(kdlon, kflev+1)
    DOUBLE PRECISION pcgaz(kdlon, kflev)
    DOUBLE PRECISION ppizaz(kdlon, kflev)
    DOUBLE PRECISION ptauaz(kdlon, kflev)
    DOUBLE PRECISION ptra1(kdlon, kflev+1)
    DOUBLE PRECISION ptra2(kdlon, kflev+1)

    ! * LOCAL VARIABLES:

    DOUBLE PRECISION zc1i(kdlon, kflev+1)
    DOUBLE PRECISION zclear(kdlon)
    DOUBLE PRECISION zcloud(kdlon)
    DOUBLE PRECISION zgg(kdlon)
    DOUBLE PRECISION zref(kdlon)
    DOUBLE PRECISION zre1(kdlon)
    DOUBLE PRECISION zre2(kdlon)
    DOUBLE PRECISION zrmuz(kdlon)
    DOUBLE PRECISION zrneb(kdlon)
    DOUBLE PRECISION zr21(kdlon)
    DOUBLE PRECISION zr22(kdlon)
    DOUBLE PRECISION zss1(kdlon)
    DOUBLE PRECISION zto1(kdlon)
    DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
    DOUBLE PRECISION ztr1(kdlon)
    DOUBLE PRECISION ztr2(kdlon)
    DOUBLE PRECISION zw(kdlon)

    INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
    DOUBLE PRECISION zfacoa, zfacoc, zcorae, zcorcd
    DOUBLE PRECISION zmue, zgap, zww, zto, zden, zden1
    DOUBLE PRECISION 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
       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))

       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))

          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(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

end module swr_m
1	guez	178	module swr_m
2
3	guez	81	IMPLICIT NONE
4
5	guez	178	contains
6	guez	81
7	guez	178	SUBROUTINE swr(knu, palbd, pcg, pcld, pomega, psec, ptau, &
8			pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, &
9			ptra2)
10			USE dimens_m
11			USE dimphy
12			USE raddim
13			USE radepsi
14			USE radopt
15	guez	81
16	guez	178	! ------------------------------------------------------------------
17			! PURPOSE.
18			! --------
19			! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
20			! CONTINUUM SCATTERING
21	guez	81
22	guez	178	! METHOD.
23			! -------
24	guez	81
25	guez	178	! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
26			! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
27	guez	81
28	guez	178	! REFERENCE.
29			! ----------
30	guez	81
31	guez	178	! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
32			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
33	guez	81
34	guez	178	! AUTHOR.
35			! -------
36			! JEAN-JACQUES MORCRETTE ECMWF
37	guez	81
38	guez	178	! MODIFICATIONS.
39			! --------------
40			! ORIGINAL : 89-07-14
41			! ------------------------------------------------------------------
42			! * ARGUMENTS:
43	guez	81
44	guez	178	INTEGER knu
45			DOUBLE PRECISION palbd(kdlon, 2)
46			DOUBLE PRECISION pcg(kdlon, 2, kflev)
47			DOUBLE PRECISION pcld(kdlon, kflev)
48			DOUBLE PRECISION pomega(kdlon, 2, kflev)
49			DOUBLE PRECISION psec(kdlon)
50			DOUBLE PRECISION ptau(kdlon, 2, kflev)
51	guez	81
52	guez	178	DOUBLE PRECISION pray1(kdlon, kflev+1)
53			DOUBLE PRECISION pray2(kdlon, kflev+1)
54			DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
55			DOUBLE PRECISION prj(kdlon, 6, kflev+1)
56			DOUBLE PRECISION prk(kdlon, 6, kflev+1)
57			DOUBLE PRECISION prmue(kdlon, kflev+1)
58			DOUBLE PRECISION pcgaz(kdlon, kflev)
59			DOUBLE PRECISION ppizaz(kdlon, kflev)
60			DOUBLE PRECISION ptauaz(kdlon, kflev)
61			DOUBLE PRECISION ptra1(kdlon, kflev+1)
62			DOUBLE PRECISION ptra2(kdlon, kflev+1)
63	guez	81
64	guez	178	! * LOCAL VARIABLES:
65	guez	81
66	guez	178	DOUBLE PRECISION zc1i(kdlon, kflev+1)
67			DOUBLE PRECISION zclear(kdlon)
68			DOUBLE PRECISION zcloud(kdlon)
69			DOUBLE PRECISION zgg(kdlon)
70			DOUBLE PRECISION zref(kdlon)
71			DOUBLE PRECISION zre1(kdlon)
72			DOUBLE PRECISION zre2(kdlon)
73			DOUBLE PRECISION zrmuz(kdlon)
74			DOUBLE PRECISION zrneb(kdlon)
75			DOUBLE PRECISION zr21(kdlon)
76			DOUBLE PRECISION zr22(kdlon)
77			DOUBLE PRECISION zss1(kdlon)
78			DOUBLE PRECISION zto1(kdlon)
79			DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
80			DOUBLE PRECISION ztr1(kdlon)
81			DOUBLE PRECISION ztr2(kdlon)
82			DOUBLE PRECISION zw(kdlon)
83	guez	81
84	guez	178	INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
85			DOUBLE PRECISION zfacoa, zfacoc, zcorae, zcorcd
86			DOUBLE PRECISION zmue, zgap, zww, zto, zden, zden1
87			DOUBLE PRECISION zmu1, zre11, zbmu0, zbmu1
88	guez	81
89	guez	178	! ------------------------------------------------------------------
90	guez	81
91	guez	178	! * 1. INITIALIZATION
92			! --------------
93	guez	81
94
95	guez	178	DO jk = 1, kflev + 1
96			DO ja = 1, 6
97			DO jl = 1, kdlon
98			prj(jl, ja, jk) = 0.
99			prk(jl, ja, jk) = 0.
100			END DO
101			END DO
102			END DO
103	guez	81
104
105	guez	178	! ------------------------------------------------------------------
106	guez	81
107	guez	178	! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
108			! ----------------------------------------------
109	guez	81
110
111	guez	178	DO jl = 1, kdlon
112			zc1i(jl, kflev+1) = 0.
113			zclear(jl) = 1.
114			zcloud(jl) = 0.
115			END DO
116	guez	81
117	guez	178	jk = 1
118	guez	81	jkl = kflev + 1 - jk
119			jklp1 = jkl + 1
120			DO jl = 1, kdlon
121	guez	178	zfacoa = 1. - ppizaz(jl, jkl)pcgaz(jl, jkl)pcgaz(jl, jkl)
122			zfacoc = 1. - pomega(jl, knu, jkl)pcg(jl, knu, jkl)pcg(jl, knu, jkl)
123			zcorae = zfacoaptauaz(jl, jkl)psec(jl)
124			zcorcd = zfacocptau(jl, knu, jkl)psec(jl)
125			zr21(jl) = exp(-zcorae)
126			zr22(jl) = exp(-zcorcd)
127			zss1(jl) = pcld(jl, jkl)(1.0-zr21(jl)zr22(jl)) + &
128			(1.0-pcld(jl,jkl))*(1.0-zr21(jl))
129	guez	81
130	guez	178	IF (novlp==1) THEN
131			! * maximum-random
132			zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
133			(1.0-min(zcloud(jl),1.-zepsec))
134			zc1i(jl, jkl) = 1.0 - zclear(jl)
135			zcloud(jl) = zss1(jl)
136			ELSE IF (novlp==2) THEN
137			! * maximum
138			zcloud(jl) = max(zss1(jl), zcloud(jl))
139			zc1i(jl, jkl) = zcloud(jl)
140			ELSE IF (novlp==3) THEN
141			! * random
142			zclear(jl) = zclear(jl)*(1.0-zss1(jl))
143			zcloud(jl) = 1.0 - zclear(jl)
144			zc1i(jl, jkl) = zcloud(jl)
145			END IF
146	guez	81	END DO
147
148	guez	178	DO jk = 2, kflev
149			jkl = kflev + 1 - jk
150			jklp1 = jkl + 1
151			DO jl = 1, kdlon
152			zfacoa = 1. - ppizaz(jl, jkl)pcgaz(jl, jkl)pcgaz(jl, jkl)
153			zfacoc = 1. - pomega(jl, knu, jkl)pcg(jl, knu, jkl)pcg(jl, knu, jkl)
154			zcorae = zfacoaptauaz(jl, jkl)psec(jl)
155			zcorcd = zfacocptau(jl, knu, jkl)psec(jl)
156			zr21(jl) = exp(-zcorae)
157			zr22(jl) = exp(-zcorcd)
158			zss1(jl) = pcld(jl, jkl)(1.0-zr21(jl)zr22(jl)) + &
159			(1.0-pcld(jl,jkl))*(1.0-zr21(jl))
160	guez	81
161	guez	178	IF (novlp==1) THEN
162			! * maximum-random
163			zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
164			(1.0-min(zcloud(jl),1.-zepsec))
165			zc1i(jl, jkl) = 1.0 - zclear(jl)
166			zcloud(jl) = zss1(jl)
167			ELSE IF (novlp==2) THEN
168			! * maximum
169			zcloud(jl) = max(zss1(jl), zcloud(jl))
170			zc1i(jl, jkl) = zcloud(jl)
171			ELSE IF (novlp==3) THEN
172			! * random
173			zclear(jl) = zclear(jl)*(1.0-zss1(jl))
174			zcloud(jl) = 1.0 - zclear(jl)
175			zc1i(jl, jkl) = zcloud(jl)
176			END IF
177			END DO
178			END DO
179	guez	81
180	guez	178	! ------------------------------------------------------------------
181	guez	81
182	guez	178	! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
183			! -----------------------------------------------
184	guez	81
185	guez	178
186	guez	81	DO jl = 1, kdlon
187	guez	178	pray1(jl, kflev+1) = 0.
188			pray2(jl, kflev+1) = 0.
189			prefz(jl, 2, 1) = palbd(jl, knu)
190			prefz(jl, 1, 1) = palbd(jl, knu)
191			ptra1(jl, kflev+1) = 1.
192			ptra2(jl, kflev+1) = 1.
193			END DO
194	guez	81
195	guez	178	DO jk = 2, kflev + 1
196			jkm1 = jk - 1
197			DO jl = 1, kdlon
198			zrneb(jl) = pcld(jl, jkm1)
199			zre1(jl) = 0.
200			ztr1(jl) = 0.
201			zre2(jl) = 0.
202			ztr2(jl) = 0.
203	guez	81
204
205	guez	178	! ------------------------------------------------------------------
206	guez	81
207	guez	178	! * 3.1 EQUIVALENT ZENITH ANGLE
208			! -----------------------
209	guez	81
210
211	guez	178	zmue = (1.-zc1i(jl,jk))psec(jl) + zc1i(jl, jk)1.66
212			prmue(jl, jk) = 1./zmue
213	guez	81
214
215	guez	178	! ------------------------------------------------------------------
216	guez	81
217	guez	178	! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
218			! ----------------------------------------------------
219	guez	81
220
221	guez	178	zgap = pcgaz(jl, jkm1)
222			zbmu0 = 0.5 - 0.75*zgap/zmue
223			zww = ppizaz(jl, jkm1)
224			zto = ptauaz(jl, jkm1)
225			zden = 1. + (1.-zww+zbmu0zww)ztozmue + (1-zww)(1.-zww+2.zbmu0zww) &
226			ztoztozmuezmue
227			pray1(jl, jkm1) = zbmu0zwwzto*zmue/zden
228			ptra1(jl, jkm1) = 1./zden
229			! PRINT ,' LOOP 342 * 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
230	guez	81
231	guez	178	zmu1 = 0.5
232			zbmu1 = 0.5 - 0.75zgapzmu1
233			zden1 = 1. + (1.-zww+zbmu1zww)zto/zmu1 + (1-zww)(1.-zww+2.zbmu1*zww &
234			)ztozto/zmu1/zmu1
235			pray2(jl, jkm1) = zbmu1zwwzto/zmu1/zden1
236			ptra2(jl, jkm1) = 1./zden1
237	guez	81
238
239	guez	178	! ------------------------------------------------------------------
240	guez	81
241	guez	178	! * 3.3 EFFECT OF CLOUD LAYER
242			! ---------------------
243	guez	81
244
245	guez	178	zw(jl) = pomega(jl, knu, jkm1)
246			zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ptauaz(jl, jkm1)/ppizaz(jl, &
247			jkm1)
248			zr21(jl) = ptau(jl, knu, jkm1) + ptauaz(jl, jkm1)
249			zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
250			zgg(jl) = zr22(jl)pcg(jl, knu, jkm1) + (1.-zr22(jl))pcgaz(jl, jkm1)
251			! Modif PhD - JJM 19/03/96 pour erreurs arrondis
252			! machine
253			! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
254			IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==1.) THEN
255			zw(jl) = 1.
256			ELSE
257			zw(jl) = zr21(jl)/zto1(jl)
258			END IF
259			zref(jl) = prefz(jl, 1, jkm1)
260			zrmuz(jl) = prmue(jl, jk)
261			END DO
262	guez	81
263	guez	178	CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
264	guez	81
265	guez	178	DO jl = 1, kdlon
266	guez	81
267	guez	178	prefz(jl, 1, jk) = (1.-zrneb(jl))(pray1(jl,jkm1)+prefz(jl,1,jkm1) &
268			ptra1(jl,jkm1)ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)prefz(jl,1, &
269			jkm1))) + zrneb(jl)*zre2(jl)
270	guez	81
271	guez	178	ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, &
272			jkm1)prefz(jl,1,jkm1)))(1.-zrneb(jl))
273	guez	81
274	guez	178	prefz(jl, 2, jk) = (1.-zrneb(jl))(pray1(jl,jkm1)+prefz(jl,2,jkm1) &
275			ptra1(jl,jkm1)ptra2(jl,jkm1)) + zrneb(jl)zre1(jl)
276	guez	81
277	guez	178	ztr(jl, 2, jkm1) = zrneb(jl)ztr1(jl) + ptra1(jl, jkm1)(1.-zrneb(jl))
278
279			END DO
280	guez	81	END DO
281	guez	178	DO jl = 1, kdlon
282			zmue = (1.-zc1i(jl,1))psec(jl) + zc1i(jl, 1)1.66
283			prmue(jl, 1) = 1./zmue
284			END DO
285	guez	81
286
287	guez	178	! ------------------------------------------------------------------
288	guez	81
289	guez	178	! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
290			! -------------------------------------------------
291	guez	81
292
293	guez	178	IF (knu==1) THEN
294			jaj = 2
295			DO jl = 1, kdlon
296			prj(jl, jaj, kflev+1) = 1.
297			prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
298			END DO
299	guez	81
300	guez	178	DO jk = 1, kflev
301			jkl = kflev + 1 - jk
302			jklp1 = jkl + 1
303			DO jl = 1, kdlon
304			zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
305			prj(jl, jaj, jkl) = zre11
306			prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
307			END DO
308			END DO
309	guez	81
310	guez	178	ELSE
311	guez	81
312	guez	178	DO jaj = 1, 2
313			DO jl = 1, kdlon
314			prj(jl, jaj, kflev+1) = 1.
315			prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
316			END DO
317	guez	81
318	guez	178	DO jk = 1, kflev
319			jkl = kflev + 1 - jk
320			jklp1 = jkl + 1
321			DO jl = 1, kdlon
322			zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
323			prj(jl, jaj, jkl) = zre11
324			prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
325			END DO
326			END DO
327			END DO
328	guez	81
329	guez	178	END IF
330	guez	81
331	guez	178	END SUBROUTINE swr
332	guez	81
333	guez	178	end module swr_m