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	module swr_m
2
3	IMPLICIT NONE
4
5	contains
6
7	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
16	! ------------------------------------------------------------------
17	! PURPOSE.
18	! --------
19	! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
20	! CONTINUUM SCATTERING
21
22	! METHOD.
23	! -------
24
25	! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
26	! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
27
28	! REFERENCE.
29	! ----------
30
31	! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
32	! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
33
34	! AUTHOR.
35	! -------
36	! JEAN-JACQUES MORCRETTE ECMWF
37
38	! MODIFICATIONS.
39	! --------------
40	! ORIGINAL : 89-07-14
41	! ------------------------------------------------------------------
42	! * ARGUMENTS:
43
44	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
52	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
64	! * LOCAL VARIABLES:
65
66	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
84	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
89	! ------------------------------------------------------------------
90
91	! * 1. INITIALIZATION
92	! --------------
93
94
95	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
104
105	! ------------------------------------------------------------------
106
107	! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
108	! ----------------------------------------------
109
110
111	DO jl = 1, kdlon
112	zc1i(jl, kflev+1) = 0.
113	zclear(jl) = 1.
114	zcloud(jl) = 0.
115	END DO
116
117	jk = 1
118	jkl = kflev + 1 - jk
119	jklp1 = jkl + 1
120	DO jl = 1, kdlon
121	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
130	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	END DO
147
148	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
161	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
180	! ------------------------------------------------------------------
181
182	! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
183	! -----------------------------------------------
184
185
186	DO jl = 1, kdlon
187	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
195	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
204
205	! ------------------------------------------------------------------
206
207	! * 3.1 EQUIVALENT ZENITH ANGLE
208	! -----------------------
209
210
211	zmue = (1.-zc1i(jl,jk))psec(jl) + zc1i(jl, jk)1.66
212	prmue(jl, jk) = 1./zmue
213
214
215	! ------------------------------------------------------------------
216
217	! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
218	! ----------------------------------------------------
219
220
221	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
231	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
238
239	! ------------------------------------------------------------------
240
241	! * 3.3 EFFECT OF CLOUD LAYER
242	! ---------------------
243
244
245	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
263	CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
264
265	DO jl = 1, kdlon
266
267	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
271	ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, &
272	jkm1)prefz(jl,1,jkm1)))(1.-zrneb(jl))
273
274	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
277	ztr(jl, 2, jkm1) = zrneb(jl)ztr1(jl) + ptra1(jl, jkm1)(1.-zrneb(jl))
278
279	END DO
280	END DO
281	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
286
287	! ------------------------------------------------------------------
288
289	! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
290	! -------------------------------------------------
291
292
293	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
300	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
310	ELSE
311
312	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
318	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
329	END IF
330
331	END SUBROUTINE swr
332
333	end module swr_m