LMDZ
sw.F90
Go to the documentation of this file.
1 SUBROUTINE sw &
2  &( kidia, kfdia , klon , klev , kaer &
3  &, psct , pcardi, ppsol , palbd, palbp , pwv, pqs &
4  &, prmu0, pcg , pcldsw, pdp , pomega, poz, ppmb &
5  &, ptau , ptave , paer &
6  &, pheat, pfdown, pfup &
7  &, pceat, pcdown, pcup &
8  &, pfdnn, pfdnv , pfupn, pfupv &
9  &, pcdnn, pcdnv , pcupn, pcupv &
10  &, psudu, puvdf , pparf &
11  &)
12 
13 !**** *SW* - COMPUTES THE SHORTWAVE RADIATION FLUXES.
14 
15 ! PURPOSE.
16 ! --------
17 
18 ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
19 ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
20 
21 !** INTERFACE.
22 ! ----------
23 
24 ! *SW* IS CALLED FROM *RADLSW*
25 
26 
27 ! IMPLICIT ARGUMENTS :
28 ! --------------------
29 
30 ! ==== INPUTS ===
31 ! ==== OUTPUTS ===
32 
33 ! METHOD.
34 ! -------
35 
36 ! 1. COMPUTES ABSORBER AMOUNTS (SWU)
37 ! 2. COMPUTES FLUXES IN U.V./VISIBLE SPECTRAL INTERVAL (SW1S)
38 ! 3. COMPUTES FLUXES IN NEAR-INFRARED SPECTRAL INTERVAL (SWNI)
39 
40 ! EXTERNALS.
41 ! ----------
42 
43 ! *SWU*, *SW1S*, *SWNI*
44 
45 ! REFERENCE.
46 ! ----------
47 
48 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
49 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
50 
51 ! AUTHOR.
52 ! -------
53 ! JEAN-JACQUES MORCRETTE *ECMWF*
54 
55 ! MODIFICATIONS.
56 ! --------------
57 ! ORIGINAL : 89-07-14
58 ! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo
59 ! 95-12-07 J.-J. MORCRETTE Near-Infrared in nsw-1 Intervals
60 ! 990128 JJMorcrette sunshine duration
61 ! 99-05-25 JJMorcrette Revised aerosols
62 ! 00-12-18 JJMorcrette 6 spectral intervals
63 
64 ! ------------------------------------------------------------------
65 
66 
67 #include "tsmbkind.h"
68 
69 USE yoerad , ONLY : nsw
70 USE yoerdu , ONLY : rcday
71 
72 
73 IMPLICIT NONE
74 
75 
76 ! DUMMY INTEGER SCALARS
77 integer_m :: kaer
78 integer_m :: kfdia
79 integer_m :: kidia
80 integer_m :: klev
81 integer_m :: klon
82 
83 ! DUMMY REAL SCALARS
84 real_b :: pcardi
85 real_b :: psct
86 
87 
88 
89 ! ------------------------------------------------------------------
90 
91 !* 0.1 ARGUMENTS
92 ! ---------
93 
94 real_b :: ppsol(klon), paer(klon,6,klev),prmu0(klon)&
95  &, pwv(klon,klev),pqs(klon,klev)
96 
97 real_b :: palbd(klon,nsw) , palbp(klon,nsw)&
98  &, pcg(klon,nsw,klev) , pcldsw(klon,klev)&
99  &, pdp(klon,klev) &
100  &, pomega(klon,nsw,klev), poz(klon,klev)&
101  &, ppmb(klon,klev+1)&
102  &, ptau(klon,nsw,klev) , ptave(klon,klev)
103 
104 real_b :: pheat(klon,klev), pfdown(klon,klev+1), pfup(klon,klev+1),&
105  &pfupv(klon), pfupn(klon), pfdnv(klon), pfdnn(klon)&
106  &, pceat(klon,klev), pcdown(klon,klev+1), pcup(klon,klev+1)&
107  &, pcupv(klon), pcupn(klon), pcdnv(klon), pcdnn(klon)&
108  &, psudu(klon), puvdf(klon), pparf(klon)
109 
110 ! ------------------------------------------------------------------
111 
112 !* 0.2 LOCAL ARRAYS
113 ! ------------
114 
115 real_b :: zaki(klon,2,nsw)&
116  &, zcld(klon,klev) , zclear(klon) &
117  &, zdsig(klon,klev) , zfact(klon)&
118  &, zfd(klon,klev+1) , zcd(klon,klev+1)&
119  &, zcdown(klon,klev+1), zcdnir(klon,klev+1), zcduvs(klon,klev+1)&
120  &, zfdown(klon,klev+1), zfdnir(klon,klev+1), zfduvs(klon,klev+1)&
121  &, zfu(klon,klev+1) , zcu(klon,klev+1)&
122  &, zcup(klon,klev+1) , zcunir(klon,klev+1), zcuuvs(klon,klev+1)&
123  &, zfup(klon,klev+1) , zfunir(klon,klev+1), zfuuvs(klon,klev+1)&
124  &, zrmu(klon) , zsec(klon) &
125  &, zsudu1(klon) , zsudu2(klon) &
126  &, zsudu1t(klon) , zsudu2t(klon) &
127  &, zud(klon,5,klev+1)
128 
129 ! LOCAL INTEGER SCALARS
130 integer_m :: inu, jk, jkl, jl, jnu, inuvs, inuir
131 
132 ! LOCAL REAL SCALARS
133 real_b :: zdcnet, zdfnet
134 
135 
136 ! ------------------------------------------------------------------
137 
138 !* 1. ABSORBER AMOUNTS AND OTHER USEFUL QUANTITIES
139 ! --------------------------------------------
140 
141 CALL swu ( kidia,kfdia ,klon ,klev &
142  &, psct ,pcardi,pcldsw,ppmb ,ppsol &
143  &, prmu0,ptave ,pwv &
144  &, zaki ,zcld ,zclear,zdsig,zfact,zrmu,zsec,zud )
145 
146 !print *,'After SWU'
147 
148 ! ------------------------------------------------------------------
149 
150 !* 2. INTERVAL (0.185/0.25-0.68 MICRON): U.V. AND VISIBLE
151 ! ---------------------------------------------------
152 
153 IF (nsw.LE.4) THEN
154  inuvs=1
155  inuir=2
156 ELSE IF (nsw.EQ.6) THEN
157  inuvs=1
158  inuir=4
159 END IF
160 
161 DO jk = 1 , klev+1
162  DO jl = kidia,kfdia
163  zfd(jl,jk) =_zero_
164  zfu(jl,jk) =_zero_
165  zcd(jl,jk) =_zero_
166  zcu(jl,jk) =_zero_
167  zsudu1t(jl)=_zero_
168  puvdf(jl) =_zero_
169  pparf(jl) =_zero_
170  ENDDO
171 ENDDO
172 
173 DO jnu = inuvs , inuir-1
174 
175  CALL sw1s &
176  &( kidia , kfdia, klon , klev , kaer , jnu &
177  &, paer , palbd , palbp, pcg , zcld , zclear &
178  &, zdsig, pomega, poz , zrmu , zsec , ptau , zud &
179  &, zfduvs,zfuuvs, zcduvs,zcuuvs, zsudu1 &
180  &)
181 
182  DO jk = 1 , klev+1
183  DO jl = kidia,kfdia
184  zfd(jl,jk)=zfd(jl,jk)+zfduvs(jl,jk)
185  zfu(jl,jk)=zfu(jl,jk)+zfuuvs(jl,jk)
186  zcd(jl,jk)=zcd(jl,jk)+zcduvs(jl,jk)
187  zcu(jl,jk)=zcu(jl,jk)+zcuuvs(jl,jk)
188  ENDDO
189  ENDDO
190  DO jl = kidia,kfdia
191  zsudu1t(jl)=zsudu1t(jl)+zsudu1(jl)
192  ENDDO
193 
194  IF (nsw.EQ.6) THEN
195  IF (jnu.LT.inuir-1) THEN
196  DO jl=kidia,kfdia
197  puvdf(jl)=puvdf(jl)+zfduvs(jl,1)
198  END DO
199  ELSE
200  DO jl=kidia,kfdia
201  pparf(jl)=pparf(jl)+zfduvs(jl,1)
202  END DO
203  END IF
204  END IF
205 
206 ENDDO
207 !print *,'After SW1S'
208 ! ------------------------------------------------------------------
209 
210 !* 3. INTERVAL (0.68-4.00 MICRON): NEAR-INFRARED
211 ! ------------------------------------------
212 
213 
214 DO jk = 1 , klev+1
215  DO jl = kidia,kfdia
216  zfdown(jl,jk)=_zero_
217  zfup(jl,jk)=_zero_
218  zcdown(jl,jk)=_zero_
219  zcup(jl,jk)=_zero_
220  zsudu2t(jl) =_zero_
221  ENDDO
222 ENDDO
223 
224 DO jnu = inuir , nsw
225 
226  CALL swni &
227  &( kidia ,kfdia , klon , klev , kaer , jnu &
228  &, paer ,zaki , palbd, palbp, pcg , zcld, zclear &
229  &, zdsig ,pomega, poz , zrmu , zsec , ptau, zud &
230  &, pwv ,pqs &
231  &, zfdnir,zfunir,zcdnir,zcunir,zsudu2 &
232  &)
233 
234  DO jk = 1 , klev+1
235  DO jl = kidia,kfdia
236  zfdown(jl,jk)=zfdown(jl,jk)+zfdnir(jl,jk)
237  zfup(jl,jk)=zfup(jl,jk)+zfunir(jl,jk)
238  zcdown(jl,jk)=zcdown(jl,jk)+zcdnir(jl,jk)
239  zcup(jl,jk)=zcup(jl,jk)+zcunir(jl,jk)
240  ENDDO
241  ENDDO
242  DO jl = kidia,kfdia
243  zsudu2t(jl)=zsudu2t(jl)+zsudu2(jl)
244  ENDDO
245 ENDDO
246 
247 ! ------------------------------------------------------------------
248 
249 !* 4. FILL THE DIAGNOSTIC ARRAYS
250 ! --------------------------
251 
252 
253 DO jl = kidia,kfdia
254  pfdnn(jl)=zfdown(jl,1)*zfact(jl)
255  pfdnv(jl)=zfd(jl,1)*zfact(jl)
256  pfupn(jl)=zfup(jl,klev+1)*zfact(jl)
257  pfupv(jl)=zfu(jl,klev+1)*zfact(jl)
258 
259  pcdnn(jl)=zcdown(jl,1)*zfact(jl)
260  pcdnv(jl)=zcd(jl,1)*zfact(jl)
261  pcupn(jl)=zcup(jl,klev+1)*zfact(jl)
262  pcupv(jl)=zcu(jl,klev+1)*zfact(jl)
263 
264  psudu(jl)=(zsudu1t(jl)+zsudu2t(jl))*zfact(jl)
265  puvdf(jl)=puvdf(jl)*zfact(jl)
266  pparf(jl)=pparf(jl)*zfact(jl)
267 ENDDO
268 
269 DO jk = 1 , klev+1
270  DO jl = kidia,kfdia
271  pfup(jl,jk) = (zfup(jl,jk) + zfu(jl,jk)) * zfact(jl)
272  pfdown(jl,jk) = (zfdown(jl,jk) + zfd(jl,jk)) * zfact(jl)
273  pcup(jl,jk) = (zcup(jl,jk) + zcu(jl,jk)) * zfact(jl)
274  pcdown(jl,jk) = (zcdown(jl,jk) + zcd(jl,jk)) * zfact(jl)
275  ENDDO
276 ENDDO
277 
278 DO jkl = 1 , klev
279  jk = klev+1 - jkl
280  DO jl = kidia,kfdia
281  zdfnet = pfup(jl,jk+1) - pfdown(jl,jk+1)-pfup(jl,jk ) + pfdown(jl,jk )
282  pheat(jl,jk) = rcday * zdfnet / pdp(jl,jkl)
283  zdcnet = pcup(jl,jk+1) - pcdown(jl,jk+1)-pcup(jl,jk ) + pcdown(jl,jk )
284  pceat(jl,jk) = rcday * zdcnet / pdp(jl,jkl)
285  ENDDO
286 ENDDO
287 
288 ! ------------------------------------------------------------------
289 
290 RETURN
291 END SUBROUTINE sw
sw
subroutine sw(KIDIA, KFDIA, KLON, KLEV, KAER, PSCT, PCARDI, PPSOL, PALBD, PALBP, PWV, PQS, PRMU0, PCG, PCLDSW, PDP, POMEGA, POZ, PPMB, PTAU, PTAVE, PAER, PFDOWN, PFUP, PCDOWN, PCUP, PFDNN, PFDNV, PFUPN, PFUPV, PCDNN, PCDNV, PCUPN, PCUPV, PSUDU, PUVDF, PPARF, PPARCF, PDIFFS, PDIRFS, LRDUST, PPIZA_DST, PCGA_DST, PTAUREL_DST)
Definition: sw.F90:13
swni
subroutine swni(KIDIA, KFDIA, KLON, KLEV, KAER, KNU, PAER, PAKI, PALBD, PALBP, PCG, PCLD, PCLEAR, PDSIG, POMEGA, POZ, PRMU, PSEC, PTAU, PUD, PWV, PQS, PFDOWN, PFUP, PCDOWN, PCUP, PSUDU2, PDIFF, PDIRF,
Definition: swni.F90:8
dimphy::kidia
integer, save kidia
Definition: dimphy.F90:6
dimphy::klon
integer, save klon
Definition: dimphy.F90:3
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
yoerad
Definition: yoerad.F90:1
yoerdu::rcday
real(kind=jprb) rcday
Definition: yoerdu.F90:17
swu
subroutine swu(KIDIA, KFDIA, KLON, KLEV, PSCT, PCARDI, PCLDSW, PPMB, PPSOL, PRMU0, PTAVE, PWV, PAKI, PCLD, PCLEAR, PDSIG, PFACT, PRMU, PSEC, PUD)
Definition: swu.F90:7
paer
INTERFACE SUBROUTINE RRTM_ECRT_140GP && paer
Definition: rrtm_ecrt_140gp.intfb.h:3
yoerdu
Definition: yoerdu.F90:1