LMDZ
swr.F90
Go to the documentation of this file.
1 SUBROUTINE swr &
2  &( kidia , kfdia , klon , klev , knu &
3  &, palbd , pcg , pcld , pomega, psec , ptau &
4  &, pcgaz , ppizaz, pray1, pray2 , prefz, prj , prk , prmue &
5  &, ptauaz, ptra1 , ptra2, ptrcld &
6  &)
7 
8 !**** *SWR* - CONTINUUM SCATTERING COMPUTATIONS
9 
10 ! PURPOSE.
11 ! --------
12 ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
13 ! CONTINUUM SCATTERING
14 
15 !** INTERFACE.
16 ! ----------
17 
18 ! *SWR* IS CALLED EITHER FROM *SW1S*
19 ! OR FROM *SWNI*
20 
21 ! IMPLICIT ARGUMENTS :
22 ! --------------------
23 
24 ! ==== INPUTS ===
25 ! ==== OUTPUTS ===
26 
27 ! METHOD.
28 ! -------
29 
30 ! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
31 ! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
32 
33 ! EXTERNALS.
34 ! ----------
35 
36 ! *SWDE*
37 
38 ! REFERENCE.
39 ! ----------
40 
41 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
42 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
43 
44 ! AUTHOR.
45 ! -------
46 ! JEAN-JACQUES MORCRETTE *ECMWF*
47 
48 ! MODIFICATIONS.
49 ! --------------
50 ! ORIGINAL : 89-07-14
51 ! Ph. DANDIN Meteo-France 05-96 : Effect of cloud layer
52 ! JJMorcrette 990128 : sunshine duration
53 ! JJMorcrette 001218 : 6 spectral intervals
54 ! ------------------------------------------------------------------
55 
56 
57 #include "tsmbkind.h"
58 
59 USE yoerad , ONLY : novlp ,nsw
60 USE yoecld , ONLY : repsec
61 USE yoeovlp , ONLY : ra1ovlp
62 
63 
64 IMPLICIT NONE
65 
66 
67 ! DUMMY INTEGER SCALARS
68 integer_m :: kfdia
69 integer_m :: kidia
70 integer_m :: klev
71 integer_m :: klon
72 integer_m :: knu
73 
74 
75 
76 ! ------------------------------------------------------------------
77 
78 !* 0.1 ARGUMENTS
79 ! ---------
80 
81 real_b :: palbd(klon,nsw) , pcg(klon,nsw,klev)&
82  &, pcld(klon,klev)&
83  &, pomega(klon,nsw,klev)&
84  &, psec(klon) , ptau(klon,nsw,klev)
85 
86 real_b :: pray1(klon,klev+1) , pray2(klon,klev+1)&
87  &, prefz(klon,2,klev+1) , prj(klon,6,klev+1)&
88  &, prk(klon,6,klev+1) , prmue(klon,klev+1)&
89  &, pcgaz(klon,klev) , ppizaz(klon,klev)&
90  &, ptauaz(klon,klev)&
91  &, ptra1(klon,klev+1) , ptra2(klon,klev+1)&
92  &, ptrcld(klon)
93 
94 ! ------------------------------------------------------------------
95 
96 !* 0.2 LOCAL ARRAYS
97 ! ------------
98 
99 real_b :: zc1i(klon,klev+1) , zcleq(klon,klev)&
100  &, zclear(klon) , zcloud(klon) &
101  &, zgg(klon) , zref(klon)&
102  &, zre1(klon) , zre2(klon)&
103  &, zrmuz(klon) , zrneb(klon)&
104  &, zr21(klon) , zr22(klon)&
105  &, zr23(klon) , zss1(klon)&
106  &, zto1(klon) , ztr(klon,2,klev+1)&
107  &, ztr1(klon) , ztr2(klon)&
108  &, zw(klon)
109 
110 ! LOCAL INTEGER SCALARS
111 integer_m :: ikl, iklp1, ja, jaj, jk, jkm1, jl, inu1
112 
113 ! LOCAL REAL SCALARS
114 real_b :: zbmu0, zbmu1, zcorae, zcorcd, zden, zden1,&
115  &zfacoa, zfacoc, zgap, zmu1, zmue, zre11, &
116  &zto, zww, zalpha1
117 
118 
119 
120 
121 ! ------------------------------------------------------------------
122 
123 !* 1. INITIALIZATION
124 ! --------------
125 
126 
127 DO jk = 1 , klev+1
128  DO ja = 1 , 6
129  DO jl = kidia,kfdia
130  prj(jl,ja,jk) = _zero_
131  prk(jl,ja,jk) = _zero_
132  ENDDO
133  ENDDO
134 ENDDO
135 
136 
137 ! ------------------------------------------------------------------
138 
139 !* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
140 ! ----------------------------------------------
141 
142 
143 DO jl = kidia,kfdia
144  zr23(jl) = _zero_
145  zc1i(jl,klev+1) = _zero_
146  zclear(jl) = _one_
147  zcloud(jl) = _zero_
148 ENDDO
149 
150 jk = 1
151 ikl = klev+1 - jk
152 iklp1 = ikl + 1
153 DO jl = kidia,kfdia
154  zfacoa = _one_ - ppizaz(jl,ikl)*pcgaz(jl,ikl)*pcgaz(jl,ikl)
155  zfacoc = _one_ - pomega(jl,knu,ikl) * pcg(jl,knu,ikl)* pcg(jl,knu,ikl)
156  zcorae = zfacoa * ptauaz(jl,ikl) * psec(jl)
157  zcorcd = zfacoc * ptau(jl,knu,ikl) * psec(jl)
158  zr21(jl) = exp(min(-zcorae,500.) )
159  zr22(jl) = exp(min(-zcorcd,500.) )
160  zss1(jl) = pcld(jl,ikl)*(_one_-zr21(jl)*zr22(jl))&
161  &+ (_one_-pcld(jl,ikl))*(_one_-zr21(jl))
162  zcleq(jl,ikl) = zss1(jl)
163 
164  IF (novlp == 1) THEN
165 !* maximum-random
166  zclear(jl) = zclear(jl)&
167  &*(_one_-max(zss1(jl),zcloud(jl)))&
168  &/(_one_-min(zcloud(jl),_one_-repsec))
169  zc1i(jl,ikl) = _one_ - zclear(jl)
170  zcloud(jl) = zss1(jl)
171  ELSEIF (novlp == 2) THEN
172 !* maximum
173  zcloud(jl) = max( zss1(jl) , zcloud(jl) )
174  zc1i(jl,ikl) = zcloud(jl)
175  ELSEIF (novlp == 3) THEN
176 !* random
177  zclear(jl) = zclear(jl)*(_one_ - zss1(jl))
178  zcloud(jl) = _one_ - zclear(jl)
179  zc1i(jl,ikl) = zcloud(jl)
180  ELSEIF (novlp == 4) THEN
181 !* Hogan & Illingworth, 2001
182  zalpha1=ra1ovlp(klev+1-jk)
183  zclear(jl)=zclear(jl)*( &
184  & zalpha1*(_one_-max(zss1(jl),zcloud(jl))) &
185  & /(_one_-min(zcloud(jl),_one_-repsec)) &
186  & +(_one_-zalpha1)*(_one_-zss1(jl)) )
187  zc1i(jl,ikl) = _one_ - zclear(jl)
188  zcloud(jl) = zss1(jl)
189  ENDIF
190 ENDDO
191 
192 DO jk = 2 , klev
193  ikl = klev+1 - jk
194  iklp1 = ikl + 1
195  DO jl = kidia,kfdia
196  zfacoa = _one_ - ppizaz(jl,ikl)*pcgaz(jl,ikl)*pcgaz(jl,ikl)
197  zfacoc = _one_ - pomega(jl,knu,ikl) * pcg(jl,knu,ikl)* pcg(jl,knu,ikl)
198  zcorae = zfacoa * ptauaz(jl,ikl) * psec(jl)
199  zcorcd = zfacoc * ptau(jl,knu,ikl) * psec(jl)
200  zr21(jl) = exp(min(-zcorae,500.) )
201  zr22(jl) = exp(min(-zcorcd,500.) )
202  zss1(jl) = pcld(jl,ikl)*(_one_-zr21(jl)*zr22(jl))&
203  &+ (_one_-pcld(jl,ikl))*(_one_-zr21(jl))
204  zcleq(jl,ikl) = zss1(jl)
205 
206  IF (novlp == 1) THEN
207 !* maximum-random
208  zclear(jl) = zclear(jl)&
209  &*(_one_-max(zss1(jl),zcloud(jl)))&
210  &/(_one_-min(zcloud(jl),_one_-repsec))
211  zc1i(jl,ikl) = _one_ - zclear(jl)
212  zcloud(jl) = zss1(jl)
213  ELSEIF (novlp == 2) THEN
214 !* maximum
215  zcloud(jl) = max( zss1(jl) , zcloud(jl) )
216  zc1i(jl,ikl) = zcloud(jl)
217  ELSEIF (novlp == 3) THEN
218 !* random
219  zclear(jl) = zclear(jl)*(_one_ - zss1(jl))
220  zcloud(jl) = _one_ - zclear(jl)
221  zc1i(jl,ikl) = zcloud(jl)
222  ELSEIF (novlp == 4) THEN
223 !* Hogan & Illingworth, 2001
224  zalpha1=ra1ovlp(klev+1-jk)
225  zclear(jl)=zclear(jl)*( &
226  & zalpha1*(_one_-max(zss1(jl),zcloud(jl))) &
227  & /(_one_-min(zcloud(jl),_one_-repsec)) &
228  & +(_one_-zalpha1)*(_one_-zss1(jl)) )
229  zc1i(jl,ikl) = _one_ - zclear(jl)
230  zcloud(jl) = zss1(jl)
231  ENDIF
232  ENDDO
233 ENDDO
234 
235 ! ------------------------------------------------------------------
236 
237 !* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
238 ! -----------------------------------------------
239 
240 
241 DO jl = kidia,kfdia
242  pray1(jl,klev+1) = _zero_
243  pray2(jl,klev+1) = _zero_
244  prefz(jl,2,1) = palbd(jl,knu)
245  prefz(jl,1,1) = palbd(jl,knu)
246  ptra1(jl,klev+1) = _one_
247  ptra2(jl,klev+1) = _one_
248 ENDDO
249 
250 DO jk = 2 , klev+1
251  jkm1 = jk-1
252  DO jl = kidia,kfdia
253  zrneb(jl)= pcld(jl,jkm1)
254  zre1(jl)=_zero_
255  ztr1(jl)=_zero_
256  zre2(jl)=_zero_
257  ztr2(jl)=_zero_
258 
259 
260 ! ------------------------------------------------------------------
261 
262 !* 3.1 EQUIVALENT ZENITH ANGLE
263 ! -----------------------
264 
265 
266  zmue = (_one_-zc1i(jl,jk)) * psec(jl)+ zc1i(jl,jk) * 1.66_jprb
267 !-- just to test Box-type computations
268 ! ZMUE = PSEC(JL)
269  prmue(jl,jk) = _one_/zmue
270 
271 
272 ! ------------------------------------------------------------------
273 
274 !* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
275 ! ----------------------------------------------------
276 
277 
278  zgap = pcgaz(jl,jkm1)
279  zbmu0 = _half_ - 0.75_jprb * zgap / zmue
280  zww = ppizaz(jl,jkm1)
281  zto = ptauaz(jl,jkm1)
282  zden = _one_ + (_one_ - zww + zbmu0 * zww) * zto * zmue &
283  &+ (1-zww) * (_one_ - zww +_two_*zbmu0*zww)*zto*zto*zmue*zmue
284  pray1(jl,jkm1) = zbmu0 * zww * zto * zmue / zden
285  ptra1(jl,jkm1) = _one_ / zden
286 
287  zmu1 = _half_
288  zbmu1 = _half_ - 0.75_jprb * zgap * zmu1
289  zden1= _one_ + (_one_ - zww + zbmu1 * zww) * zto / zmu1 &
290  &+ (1-zww) * (_one_ - zww +_two_*zbmu1*zww)*zto*zto/zmu1/zmu1
291  pray2(jl,jkm1) = zbmu1 * zww * zto / zmu1 / zden1
292  ptra2(jl,jkm1) = _one_ / zden1
293 
294 
295 ! ------------------------------------------------------------------
296 
297 !* 3.3 EFFECT OF CLOUD LAYER
298 ! ---------------------
299 
300 
301  zw(jl) = pomega(jl,knu,jkm1)
302  zto1(jl) = ptau(jl,knu,jkm1)/zw(jl)+ ptauaz(jl,jkm1)/ppizaz(jl,jkm1)
303  zr21(jl) = ptau(jl,knu,jkm1) + ptauaz(jl,jkm1)
304  zr22(jl) = ptau(jl,knu,jkm1) / zr21(jl)
305  zgg(jl) = zr22(jl) * pcg(jl,knu,jkm1)&
306  &+ (_one_ - zr22(jl)) * pcgaz(jl,jkm1)
307  IF (zw(jl) == _one_ .AND. ppizaz(jl,jkm1) == _one_) THEN
308  zw(jl)=_one_
309  ELSE
310  zw(jl) = zr21(jl) / zto1(jl)
311  ENDIF
312  zref(jl) = prefz(jl,1,jkm1)
313  zrmuz(jl) = prmue(jl,jk)
314  ENDDO
315 
316  CALL swde ( kidia, kfdia , klon &
317  &, zgg , zref , zrmuz , zto1 , zw &
318  &, zre1 , zre2 , ztr1 , ztr2 )
319 
320  DO jl = kidia,kfdia
321 
322  prefz(jl,1,jk) = (_one_-zrneb(jl)) * (pray1(jl,jkm1)&
323  &+ prefz(jl,1,jkm1) * ptra1(jl,jkm1)&
324  &* ptra2(jl,jkm1)&
325  &/ (_one_-pray2(jl,jkm1)*prefz(jl,1,jkm1)))&
326  &+ zrneb(jl) * zre2(jl)
327 
328  ztr(jl,1,jkm1) = zrneb(jl) * ztr2(jl) + (ptra1(jl,jkm1)&
329  &/ (_one_-pray2(jl,jkm1)*prefz(jl,1,jkm1)))&
330  &* (_one_-zrneb(jl))
331 
332  prefz(jl,2,jk) = (_one_-zrneb(jl)) * (pray1(jl,jkm1)&
333  &+ prefz(jl,2,jkm1) * ptra1(jl,jkm1)&
334  &* ptra2(jl,jkm1) )&
335  &+ zrneb(jl) * zre1(jl)
336 
337  ztr(jl,2,jkm1) = zrneb(jl) * ztr1(jl)+ ptra1(jl,jkm1) * (_one_-zrneb(jl))
338 
339  ENDDO
340 ENDDO
341 DO jl = kidia,kfdia
342  zmue = (_one_-zc1i(jl,1))*psec(jl)+zc1i(jl,1)*1.66_jprb
343 !-- just to test Box-type computations
344 ! ZMUE = PSEC(JL)
345  prmue(jl,1)=_one_/zmue
346  ptrcld(jl)=_one_-zc1i(jl,1)
347 ENDDO
348 
349 
350 ! ------------------------------------------------------------------
351 
352 !* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
353 ! -------------------------------------------------
354 
355 
356 IF (nsw <= 4) THEN
357  inu1=1
358 ELSE IF (nsw == 6) THEN
359  inu1=3
360 END IF
361 
362 IF (knu <= inu1) THEN
363  jaj = 2
364  DO jl = kidia,kfdia
365  prj(jl,jaj,klev+1) = _one_
366  prk(jl,jaj,klev+1) = prefz(jl, 1,klev+1)
367  ENDDO
368 
369  DO jk = 1 , klev
370  ikl = klev+1 - jk
371  iklp1 = ikl + 1
372  DO jl = kidia,kfdia
373  zre11= prj(jl,jaj,iklp1) * ztr(jl, 1,ikl)
374  prj(jl,jaj,ikl) = zre11
375  prk(jl,jaj,ikl) = zre11 * prefz(jl, 1,ikl)
376  ENDDO
377  ENDDO
378 
379 ELSE
380 
381  DO jaj = 1 , 2
382  DO jl = kidia,kfdia
383  prj(jl,jaj,klev+1) = _one_
384  prk(jl,jaj,klev+1) = prefz(jl,jaj,klev+1)
385  ENDDO
386 
387  DO jk = 1 , klev
388  ikl = klev+1 - jk
389  iklp1 = ikl + 1
390  DO jl = kidia,kfdia
391  zre11= prj(jl,jaj,iklp1) * ztr(jl,jaj,ikl)
392  prj(jl,jaj,ikl) = zre11
393  prk(jl,jaj,ikl) = zre11 * prefz(jl,jaj,ikl)
394  ENDDO
395  ENDDO
396  ENDDO
397 
398 ENDIF
399 
400 ! ------------------------------------------------------------------
401 
402 RETURN
403 END SUBROUTINE swr
dimphy::kidia
integer, save kidia
Definition: dimphy.F90:6
dimphy::klon
integer, save klon
Definition: dimphy.F90:3
yoerad::novlp
integer(kind=jpim) novlp
Definition: yoerad.F90:24
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
yoecld::repsec
real(kind=jprb) repsec
Definition: yoecld.F90:37
dimphy::kfdia
integer, save kfdia
Definition: dimphy.F90:5
swr
subroutine swr(KIDIA, KFDIA, KLON, KLEV, KNU, PALBD, PCG, PCLD, POMEGA, PSEC, PTAU, PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMUE, PTAUAZ, PTRA1, PTRA2, PTRCLD)
Definition: swr.F90:7
yoerad
Definition: yoerad.F90:1
yoeovlp::ra1ovlp
real(kind=jprb), dimension(:), allocatable ra1ovlp
Definition: yoeovlp.F90:13
yoecld
Definition: yoecld.F90:1
swde
subroutine swde(KIDIA, KFDIA, KLON, PGG, PREF, PRMUZ, PTO1, PW, PRE1, PRE2, PTR1, PTR2)
Definition: swde.F90:7