phylmd/Radlwsw/swr.f90

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 raddim, only: kdlon, kflev
    USE radepsi, only: zepsec
    USE radopt, only: novlp
    use swde_m, only: swde

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