LMDZ
sw1s.F90
Go to the documentation of this file.
1 SUBROUTINE sw1s &
2  &( kidia , kfdia , klon , klev , kaer , knu &
3  &, paer , palbd , palbp, pcg , pcld , pclear &
4  &, pdsig , pomega, poz , prmu , psec , ptau , pud &
5  &, pfd , pfu , pcd , pcu , psudu1 &
6  &)
7 
8 !**** *SW1S* - SHORTWAVE RADIATION, FIRST SPECTRAL INTERVAL
9 
10 ! PURPOSE.
11 ! --------
12 
13 ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
14 ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
15 
16 !** INTERFACE.
17 ! ----------
18 
19 ! *SW1S* IS CALLED FROM *SW*.
20 
21 
22 ! IMPLICIT ARGUMENTS :
23 ! --------------------
24 
25 ! ==== INPUTS ===
26 ! ==== OUTPUTS ===
27 
28 ! METHOD.
29 ! -------
30 
31 ! 1. COMPUTES QUANTITIES FOR THE CLEAR-SKY FRACTION OF THE
32 ! COLUMN
33 ! 2. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
34 ! CONTINUUM SCATTERING
35 ! 3. MULTIPLY BY OZONE TRANSMISSION FUNCTION
36 
37 ! EXTERNALS.
38 ! ----------
39 
40 ! *SWCLR*, *SWR*, *SWTT*, *SWUVO3*
41 
42 ! REFERENCE.
43 ! ----------
44 
45 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
46 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
47 
48 ! AUTHOR.
49 ! -------
50 ! JEAN-JACQUES MORCRETTE *ECMWF*
51 
52 ! MODIFICATIONS.
53 ! --------------
54 ! ORIGINAL : 89-07-14
55 ! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
56 ! 96-01-15 J.-J. MORCRETTE SW in nsw SPECTRAL INTERVALS
57 ! 990128 JJMorcrette sunshine duration
58 ! 99-05-25 JJMorcrette Revised aerosols
59 ! 00-12-18 JJMorcrette 6 spectral intervals
60 
61 ! ------------------------------------------------------------------
62 
63 
64 #include "tsmbkind.h"
65 
66 USE yoesw , ONLY : rray ,rsun
67 USE yoerad , ONLY : nsw
68 
69 
70 IMPLICIT NONE
71 
72 
73 ! DUMMY INTEGER SCALARS
74 integer_m :: kaer
75 integer_m :: kfdia
76 integer_m :: kidia
77 integer_m :: kkind
78 integer_m :: klev
79 integer_m :: klon
80 integer_m :: knu
81 
82 
83 
84 ! ------------------------------------------------------------------
85 
86 !* 0.1 ARGUMENTS
87 ! ---------
88 
89 real_b :: paer(klon,6,klev)&
90  &, palbd(klon,nsw) , palbp(klon,nsw)&
91  &, pcg(klon,nsw,klev) , pcld(klon,klev) &
92  &, pclear(klon)&
93  &, pdsig(klon,klev)&
94  &, pomega(klon,nsw,klev), poz(klon,klev)&
95  &, prmu(klon) , psec(klon)&
96  &, ptau(klon,nsw,klev) , pud(klon,5,klev+1)
97 
98 real_b :: pfd(klon,klev+1) , pfu(klon,klev+1)&
99  &, pcd(klon,klev+1) , pcu(klon,klev+1)&
100  &, psudu1(klon)
101 
102 ! ------------------------------------------------------------------
103 
104 !* 0.2 LOCAL ARRAYS
105 ! ------------
106 
107 integer_m :: iind6(6), iind4(4)
108 
109 real_b :: zcgaz(klon,klev)&
110  &, zdiff(klon) , zdirf(klon) &
111  &, zdift(klon) , zdirt(klon) &
112  &, zpizaz(klon,klev)&
113  &, zrayl(klon), zray1(klon,klev+1), zray2(klon,klev+1)&
114  &, zrefz(klon,2,klev+1)&
115  &, zrj(klon,6,klev+1), zrj0(klon,6,klev+1)&
116  &, zrk(klon,6,klev+1), zrk0(klon,6,klev+1)&
117  &, zrmue(klon,klev+1), zrmu0(klon,klev+1)&
118  &, zr6(klon,6) , zr4(klon,4)&
119  &, ztauaz(klon,klev)&
120  &, ztra1(klon,klev+1), ztra2(klon,klev+1)&
121  &, ztrcld(klon) , ztrclr(klon)&
122  &, zw6(klon,6) , zw4(klon,4), zo(klon,2) ,zt(klon,2)
123 
124 ! LOCAL INTEGER SCALARS
125 integer_m :: ikl, ikm1, jaj, jk, jl
126 
127 
128 ! ------------------------------------------------------------------
129 
130 !* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
131 ! ----------------------- ------------------
132 
133 
134 !* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
135 ! -----------------------------------------
136 
137 
138 DO jl = kidia,kfdia
139  zrayl(jl) = rray(knu,1) + prmu(jl) * (rray(knu,2) + prmu(jl)&
140  &* (rray(knu,3) + prmu(jl) * (rray(knu,4) + prmu(jl)&
141  &* (rray(knu,5) + prmu(jl) * rray(knu,6) ))))
142 ENDDO
143 !print *,'SW1S After Rayleigh'
144 
145 
146 ! ------------------------------------------------------------------
147 
148 !* 2. CONTINUUM SCATTERING CALCULATIONS
149 ! ---------------------------------
150 
151 
152 !* 2.1 CLEAR-SKY FRACTION OF THE COLUMN
153 ! --------------------------------
154 
155 
156 CALL swclr &
157  &( kidia , kfdia , klon , klev , kaer , knu &
158  &, paer , palbp , pdsig , zrayl, psec &
159  &, zcgaz , zpizaz, zray1 , zray2, zrefz, zrj0 &
160  &, zrk0 , zrmu0 , ztauaz, ztra1, ztra2, ztrclr &
161  &)
162 !print *,'SW1S After SWCLR'
163 
164 
165 !* 2.2 CLOUDY FRACTION OF THE COLUMN
166 ! -----------------------------
167 
168 
169 CALL swr &
170  &( kidia ,kfdia ,klon ,klev , knu &
171  &, palbd ,pcg ,pcld ,pomega, psec , ptau &
172  &, zcgaz ,zpizaz,zray1 ,zray2 , zrefz, zrj ,zrk , zrmue &
173  &, ztauaz,ztra1 ,ztra2 ,ztrcld &
174  &)
175 !print *,'SW1S After SWR'
176 
177 
178 ! ------------------------------------------------------------------
179 
180 !* 3. OZONE ABSORPTION
181 ! ----------------
182 
183 IF (nsw <= 4) THEN
184 
185 !* 3.1 TWO OR FOUR SPECTRAL INTERVALS
186 ! ------------------------------
187 
188  iind6(1)=1
189  iind6(2)=2
190  iind6(3)=3
191  iind6(4)=1
192  iind6(5)=2
193  iind6(6)=3
194 
195 
196 !* 3.1.1 DOWNWARD FLUXES
197 ! ---------------
198 
199 
200  jaj = 2
201 
202  DO jl = kidia,kfdia
203  zw6(jl,1)=_zero_
204  zw6(jl,2)=_zero_
205  zw6(jl,3)=_zero_
206  zw6(jl,4)=_zero_
207  zw6(jl,5)=_zero_
208  zw6(jl,6)=_zero_
209  pfd(jl,klev+1)=((_one_-pclear(jl))*zrj(jl,jaj,klev+1)&
210  &+ pclear(jl) *zrj0(jl,jaj,klev+1)) * rsun(knu)
211  pcd(jl,klev+1)= zrj0(jl,jaj,klev+1) * rsun(knu)
212  ENDDO
213  DO jk = 1 , klev
214  ikl = klev+1-jk
215  DO jl = kidia,kfdia
216  zw6(jl,1)=zw6(jl,1)+pud(jl,1,ikl)/zrmue(jl,ikl)
217  zw6(jl,2)=zw6(jl,2)+pud(jl,2,ikl)/zrmue(jl,ikl)
218  zw6(jl,3)=zw6(jl,3)+poz(jl, ikl)/zrmue(jl,ikl)
219  zw6(jl,4)=zw6(jl,4)+pud(jl,1,ikl)/zrmu0(jl,ikl)
220  zw6(jl,5)=zw6(jl,5)+pud(jl,2,ikl)/zrmu0(jl,ikl)
221  zw6(jl,6)=zw6(jl,6)+poz(jl, ikl)/zrmu0(jl,ikl)
222  ENDDO
223 
224  kkind=6
225  CALL swtt1 ( kidia, kfdia, klon, knu, kkind &
226  &, iind6 &
227  &, zw6 &
228  &, zr6 )
229 
230  DO jl = kidia,kfdia
231  zdiff(jl) = zr6(jl,1)*zr6(jl,2)*zr6(jl,3)*zrj(jl,jaj,ikl)
232  zdirf(jl) = zr6(jl,4)*zr6(jl,5)*zr6(jl,6)*zrj0(jl,jaj,ikl)
233  pfd(jl,ikl) = ((_one_-pclear(jl)) * zdiff(jl)&
234  &+pclear(jl) * zdirf(jl)) * rsun(knu)
235  pcd(jl,ikl) = zdirf(jl) * rsun(knu)
236  ENDDO
237  ENDDO
238 
239  DO jl=kidia,kfdia
240  zdift(jl) = zr6(jl,1)*zr6(jl,2)*zr6(jl,3)*ztrcld(jl)
241  zdirt(jl) = zr6(jl,4)*zr6(jl,5)*zr6(jl,6)*ztrclr(jl)
242  psudu1(jl) = ((_one_-pclear(jl)) * zdift(jl)&
243  &+pclear(jl) * zdirt(jl)) * rsun(knu)
244  ENDDO
245 
246 
247 !* 3.1.2 UPWARD FLUXES
248 ! -------------
249 
250 
251  DO jl = kidia,kfdia
252  pfu(jl,1) = ((_one_-pclear(jl))*zdiff(jl)*palbd(jl,knu)&
253  &+ pclear(jl) *zdirf(jl)*palbp(jl,knu))&
254  &* rsun(knu)
255  pcu(jl,1) = zdirf(jl) * palbp(jl,knu) * rsun(knu)
256  ENDDO
257 
258  DO jk = 2 , klev+1
259  ikm1=jk-1
260  DO jl = kidia,kfdia
261  zw6(jl,1)=zw6(jl,1)+pud(jl,1,ikm1)*1.66_jprb
262  zw6(jl,2)=zw6(jl,2)+pud(jl,2,ikm1)*1.66_jprb
263  zw6(jl,3)=zw6(jl,3)+poz(jl, ikm1)*1.66_jprb
264  zw6(jl,4)=zw6(jl,4)+pud(jl,1,ikm1)*1.66_jprb
265  zw6(jl,5)=zw6(jl,5)+pud(jl,2,ikm1)*1.66_jprb
266  zw6(jl,6)=zw6(jl,6)+poz(jl, ikm1)*1.66_jprb
267  ENDDO
268 
269  kkind=6
270  CALL swtt1 ( kidia, kfdia, klon, knu, kkind &
271  &, iind6 &
272  &, zw6 &
273  &, zr6 )
274 
275  DO jl = kidia,kfdia
276  zdiff(jl) = zr6(jl,1)*zr6(jl,2)*zr6(jl,3)*zrk(jl,jaj,jk)
277  zdirf(jl) = zr6(jl,4)*zr6(jl,5)*zr6(jl,6)*zrk0(jl,jaj,jk)
278  pfu(jl,jk) = ((_one_-pclear(jl)) * zdiff(jl)&
279  &+pclear(jl) * zdirf(jl)) * rsun(knu)
280  pcu(jl,jk) = zdirf(jl) * rsun(knu)
281  ENDDO
282  ENDDO
283 
284 
285 
286 
287 ELSE IF (nsw == 6) THEN
288 !print *,'SW1S ozone 6SI'
289 
290 !* 3.2 SIX SPECTRAL INTERVALS
291 ! ----------------------
292 
293  iind4(1)=1
294  iind4(2)=2
295  iind4(3)=1
296  iind4(4)=2
297 
298 
299 !* 3.2,1 DOWNWARD FLUXES
300 ! ---------------
301 
302 
303  jaj = 2
304 
305  DO jl = kidia,kfdia
306  zw4(jl,1)=_zero_
307  zw4(jl,2)=_zero_
308  zw4(jl,3)=_zero_
309  zw4(jl,4)=_zero_
310 
311  zo(jl,1)=_zero_
312  zo(jl,2)=_zero_
313  pfd(jl,klev+1)=((_one_-pclear(jl))*zrj(jl,jaj,klev+1)&
314  &+ pclear(jl) *zrj0(jl,jaj,klev+1)) * rsun(knu)
315  pcd(jl,klev+1)= zrj0(jl,jaj,klev+1) * rsun(knu)
316  ENDDO
317  DO jk = 1 , klev
318  ikl = klev+1-jk
319  DO jl = kidia,kfdia
320  zw4(jl,1)=zw4(jl,1)+pud(jl,1,ikl)/zrmue(jl,ikl)
321  zw4(jl,2)=zw4(jl,2)+pud(jl,2,ikl)/zrmue(jl,ikl)
322  zw4(jl,3)=zw4(jl,3)+pud(jl,1,ikl)/zrmu0(jl,ikl)
323  zw4(jl,4)=zw4(jl,4)+pud(jl,2,ikl)/zrmu0(jl,ikl)
324 
325  zo(jl,1)=zo(jl,1)+poz(jl, ikl)/zrmue(jl,ikl)
326  zo(jl,2)=zo(jl,2)+poz(jl, ikl)/zrmu0(jl,ikl)
327  ENDDO
328 
329  kkind=4
330  CALL swtt1 ( kidia, kfdia, klon, knu, kkind &
331  &, iind4 &
332  &, zw4 &
333  &, zr4 &
334  & )
335 ! print *,'SW1S after SWTT1 JK=',JK
336 
337  kkind=2
338  CALL swuvo3 ( kidia, kfdia, klon, knu, kkind &
339  &, zo &
340  &, zt &
341  & )
342 ! print *,'SW1S after SWUVO3 JK=',JK
343 
344  DO jl = kidia,kfdia
345  zdiff(jl) = zr4(jl,1)*zr4(jl,2)*zt(jl,1)*zrj(jl,jaj,ikl)
346  zdirf(jl) = zr4(jl,3)*zr4(jl,4)*zt(jl,2)*zrj0(jl,jaj,ikl)
347  pfd(jl,ikl) = ((_one_-pclear(jl)) * zdiff(jl)&
348  &+pclear(jl) * zdirf(jl)) * rsun(knu)
349  pcd(jl,ikl) = zdirf(jl) * rsun(knu)
350  ENDDO
351  ENDDO
352 
353  DO jl=kidia,kfdia
354  zdift(jl) = zr4(jl,1)*zr4(jl,2)*zt(jl,1)*ztrcld(jl)
355  zdirt(jl) = zr4(jl,3)*zr4(jl,4)*zt(jl,2)*ztrclr(jl)
356  psudu1(jl) = ((_one_-pclear(jl)) * zdift(jl)&
357  &+pclear(jl) * zdirt(jl)) * rsun(knu)
358  ENDDO
359 
360 
361 !* 3.2.2 UPWARD FLUXES
362 ! -------------
363 
364 
365  DO jl = kidia,kfdia
366  pfu(jl,1) = ((_one_-pclear(jl))*zdiff(jl)*palbd(jl,knu)&
367  &+ pclear(jl) *zdirf(jl)*palbp(jl,knu))&
368  &* rsun(knu)
369  pcu(jl,1) = zdirf(jl) * palbp(jl,knu) * rsun(knu)
370  ENDDO
371 
372  DO jk = 2 , klev+1
373  ikm1=jk-1
374  DO jl = kidia,kfdia
375  zw4(jl,1)=zw4(jl,1)+pud(jl,1,ikm1)*1.66_jprb
376  zw4(jl,2)=zw4(jl,2)+pud(jl,2,ikm1)*1.66_jprb
377  zw4(jl,3)=zw4(jl,3)+pud(jl,1,ikm1)*1.66_jprb
378  zw4(jl,4)=zw4(jl,4)+pud(jl,2,ikm1)*1.66_jprb
379 
380  zo(jl,1)=zo(jl,1)+poz(jl, ikm1)*1.66_jprb
381  zo(jl,2)=zo(jl,2)+poz(jl, ikm1)*1.66_jprb
382  ENDDO
383 
384  kkind=4
385  CALL swtt1 ( kidia, kfdia, klon, knu, kkind &
386  &, iind4 &
387  &, zw4 &
388  &, zr4 &
389  & )
390 
391  kkind=2
392  CALL swuvo3 ( kidia, kfdia, klon, knu, kkind &
393  &, zo &
394  &, zt &
395  & )
396 
397  DO jl = kidia,kfdia
398  zdiff(jl) = zr4(jl,1)*zr4(jl,2)*zt(jl,1)*zrk(jl,jaj,jk)
399  zdirf(jl) = zr4(jl,3)*zr4(jl,4)*zt(jl,2)*zrk0(jl,jaj,jk)
400  pfu(jl,jk) = ((_one_-pclear(jl)) * zdiff(jl)&
401  &+pclear(jl) * zdirf(jl)) * rsun(knu)
402  pcu(jl,jk) = zdirf(jl) * rsun(knu)
403  ENDDO
404  ENDDO
405 
406 END IF
407 
408 ! ------------------------------------------------------------------
409 
410 RETURN
411 END SUBROUTINE sw1s
swclr
subroutine swclr(KIDIA, KFDIA, KLON, KLEV, KAER, KNU, PAER, PALBP, PDSIG, PRAYL, PSEC, PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMU0, PTAUAZ, PTRA1, PTRA2, PTRCLR,
Definition: swclr.F90:7
yoesw
Definition: yoesw.F90:1
dimphy::kidia
integer, save kidia
Definition: dimphy.F90:6
dimphy::klon
integer, save klon
Definition: dimphy.F90:3
yoesw::rsun
real(kind=jprb), dimension(:), allocatable rsun
Definition: yoesw.F90:16
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
sw1s
subroutine sw1s(KIDIA, KFDIA, KLON, KLEV, KAER, KNU, PAER, PALBD, PALBP, PCG, PCLD, PCLEAR, PDSIG, POMEGA, POZ, PRMU, PSEC, PTAU, PUD, PFD, PFU, PCD, PCU, PSUDU1, PDIFF, PDIRF,
Definition: sw1s.F90:7
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
swuvo3
subroutine swuvo3(KIDIA, KFDIA, KLON, KNU, KABS, PU, PTR)
Definition: swuvo3.F90:5
yoerad
Definition: yoerad.F90:1
swtt1
subroutine swtt1(KIDIA, KFDIA, KLON, KNU, KABS, KIND, PU, PTR)
Definition: swtt1.F90:2
yoesw::rray
real(kind=jprb), dimension(6, 6) rray
Definition: yoesw.F90:15
paer
INTERFACE SUBROUTINE RRTM_ECRT_140GP && paer
Definition: rrtm_ecrt_140gp.intfb.h:3