1 | !WRF:MODEL_LAYER:PHYSICS |
---|
2 | ! |
---|
3 | MODULE module_ra_sw |
---|
4 | |
---|
5 | REAL,PRIVATE,SAVE :: CSSCA |
---|
6 | |
---|
7 | CONTAINS |
---|
8 | |
---|
9 | !------------------------------------------------------------------ |
---|
10 | SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO, & |
---|
11 | rho_phy,T3D,QV3D,QC3D,QR3D, & |
---|
12 | QI3D,QS3D,QG3D,P3D,pi3D,dz8w,GMT, & |
---|
13 | R,CP,G,JULDAY, & |
---|
14 | XTIME,DECLIN,SOLCON, & |
---|
15 | F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & |
---|
16 | pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & |
---|
17 | RADFRQ,ICLOUD,DEGRAD,warm_rain, & |
---|
18 | ids,ide, jds,jde, kds,kde, & |
---|
19 | ims,ime, jms,jme, kms,kme, & |
---|
20 | its,ite, jts,jte, kts,kte, & |
---|
21 | slope_rad,topo_shading,ht, & ! Optional |
---|
22 | dx,dy,sina,cosa,shadowmask, & ! Optional |
---|
23 | cosz_urb2d,omg_urb2d & !Optional urban |
---|
24 | ) |
---|
25 | !------------------------------------------------------------------ |
---|
26 | IMPLICIT NONE |
---|
27 | !------------------------------------------------------------------ |
---|
28 | INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & |
---|
29 | ims,ime, jms,jme, kms,kme, & |
---|
30 | its,ite, jts,jte, kts,kte |
---|
31 | |
---|
32 | LOGICAL, INTENT(IN ) :: warm_rain |
---|
33 | INTEGER, INTENT(IN ) :: icloud |
---|
34 | |
---|
35 | REAL, INTENT(IN ) :: RADFRQ,DEGRAD, & |
---|
36 | XTIME,DECLIN,SOLCON |
---|
37 | ! |
---|
38 | REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & |
---|
39 | INTENT(IN ) :: P3D, & |
---|
40 | pi3D, & |
---|
41 | rho_phy, & |
---|
42 | dz8w, & |
---|
43 | T3D |
---|
44 | REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & |
---|
45 | INTENT(IN ) :: pm2_5_dry, & |
---|
46 | pm2_5_water, & |
---|
47 | pm2_5_dry_ec |
---|
48 | |
---|
49 | |
---|
50 | REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & |
---|
51 | INTENT(INOUT) :: RTHRATEN |
---|
52 | ! |
---|
53 | REAL, DIMENSION( ims:ime, jms:jme ), & |
---|
54 | INTENT(IN ) :: XLAT, & |
---|
55 | XLONG, & |
---|
56 | ALBEDO |
---|
57 | ! |
---|
58 | REAL, DIMENSION( ims:ime, jms:jme ), & |
---|
59 | INTENT(INOUT) :: GSW |
---|
60 | ! |
---|
61 | REAL, INTENT(IN ) :: GMT,R,CP,G,dt |
---|
62 | ! |
---|
63 | INTEGER, INTENT(IN ) :: JULDAY |
---|
64 | |
---|
65 | |
---|
66 | |
---|
67 | ! |
---|
68 | ! Optional |
---|
69 | ! |
---|
70 | REAL, OPTIONAL, INTENT(IN) :: dx,dy |
---|
71 | |
---|
72 | REAL, DIMENSION( ims:ime, jms:jme ), & |
---|
73 | OPTIONAL, INTENT(IN) :: sina,cosa,ht |
---|
74 | REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & |
---|
75 | OPTIONAL, & |
---|
76 | INTENT(IN ) :: & |
---|
77 | QV3D, & |
---|
78 | QC3D, & |
---|
79 | QR3D, & |
---|
80 | QI3D, & |
---|
81 | QS3D, & |
---|
82 | QG3D |
---|
83 | |
---|
84 | INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,topo_shading |
---|
85 | |
---|
86 | INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: shadowmask |
---|
87 | |
---|
88 | LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG |
---|
89 | |
---|
90 | REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D, OMG_URB2D !Optional urban |
---|
91 | ! LOCAL VARS |
---|
92 | |
---|
93 | REAL, DIMENSION( kts:kte ) :: & |
---|
94 | TTEN1D, & |
---|
95 | RHO01D, & |
---|
96 | P1D, & |
---|
97 | DZ, & |
---|
98 | T1D, & |
---|
99 | QV1D, & |
---|
100 | QC1D, & |
---|
101 | QR1D, & |
---|
102 | QI1D, & |
---|
103 | QS1D, & |
---|
104 | QG1D |
---|
105 | ! |
---|
106 | REAL:: XLAT0,XLONG0,ALB0,GSW0 |
---|
107 | |
---|
108 | REAL :: COSZ, OMG !urban |
---|
109 | ! |
---|
110 | INTEGER :: i,j,K,NK |
---|
111 | LOGICAL :: predicate , do_topo_shading |
---|
112 | real :: aer_dry1(kts:kte),aer_water1(kts:kte) |
---|
113 | |
---|
114 | real :: sinalpha,cosalpha,hx,hy,slope,slp_azi,pi |
---|
115 | integer :: shadow |
---|
116 | |
---|
117 | !------------------------------------------------------------------ |
---|
118 | |
---|
119 | pi = 4.*atan(1.) |
---|
120 | |
---|
121 | j_loop: DO J=jts,jte |
---|
122 | i_loop: DO I=its,ite |
---|
123 | |
---|
124 | ! reverse vars |
---|
125 | DO K=kts,kte |
---|
126 | QV1D(K)=0. |
---|
127 | QC1D(K)=0. |
---|
128 | QR1D(K)=0. |
---|
129 | QI1D(K)=0. |
---|
130 | QS1D(K)=0. |
---|
131 | QG1D(K)=0. |
---|
132 | ENDDO |
---|
133 | |
---|
134 | DO K=kts,kte |
---|
135 | NK=kme-1-K+kms |
---|
136 | TTEN1D(K)=0. |
---|
137 | |
---|
138 | T1D(K)=T3D(I,NK,J) |
---|
139 | P1D(K)=P3D(I,NK,J) |
---|
140 | RHO01D(K)=rho_phy(I,NK,J) |
---|
141 | DZ(K)=dz8w(I,NK,J) |
---|
142 | ENDDO |
---|
143 | |
---|
144 | IF( PRESENT(pm2_5_dry) .AND. PRESENT(pm2_5_water) )THEN |
---|
145 | DO K=kts,kte |
---|
146 | NK=kme-1-K+kms |
---|
147 | aer_dry1(k) = pm2_5_dry(i,nk,j) |
---|
148 | aer_water1(k) = pm2_5_water(i,nk,j) |
---|
149 | ENDDO |
---|
150 | ELSE |
---|
151 | DO K=kts,kte |
---|
152 | aer_dry1(k) = 0. |
---|
153 | aer_water1(k) = 0. |
---|
154 | ENDDO |
---|
155 | ENDIF |
---|
156 | |
---|
157 | IF (PRESENT(F_QV) .AND. PRESENT(QV3D)) THEN |
---|
158 | IF (F_QV) THEN |
---|
159 | DO K=kts,kte |
---|
160 | NK=kme-1-K+kms |
---|
161 | QV1D(K)=QV3D(I,NK,J) |
---|
162 | QV1D(K)=max(0.,QV1D(K)) |
---|
163 | ENDDO |
---|
164 | ENDIF |
---|
165 | ENDIF |
---|
166 | |
---|
167 | IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN |
---|
168 | IF (F_QC) THEN |
---|
169 | DO K=kts,kte |
---|
170 | NK=kme-1-K+kms |
---|
171 | QC1D(K)=QC3D(I,NK,J) |
---|
172 | QC1D(K)=max(0.,QC1D(K)) |
---|
173 | ENDDO |
---|
174 | ENDIF |
---|
175 | ENDIF |
---|
176 | |
---|
177 | IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN |
---|
178 | IF (F_QR) THEN |
---|
179 | DO K=kts,kte |
---|
180 | NK=kme-1-K+kms |
---|
181 | QR1D(K)=QR3D(I,NK,J) |
---|
182 | QR1D(K)=max(0.,QR1D(K)) |
---|
183 | ENDDO |
---|
184 | ENDIF |
---|
185 | ENDIF |
---|
186 | |
---|
187 | ! |
---|
188 | IF ( PRESENT( F_QI ) ) THEN |
---|
189 | predicate = F_QI |
---|
190 | ELSE |
---|
191 | predicate = .FALSE. |
---|
192 | ENDIF |
---|
193 | |
---|
194 | IF ( predicate .AND. PRESENT( QI3D ) ) THEN |
---|
195 | DO K=kts,kte |
---|
196 | NK=kme-1-K+kms |
---|
197 | QI1D(K)=QI3D(I,NK,J) |
---|
198 | QI1D(K)=max(0.,QI1D(K)) |
---|
199 | ENDDO |
---|
200 | ELSE |
---|
201 | IF (.not. warm_rain) THEN |
---|
202 | DO K=kts,kte |
---|
203 | IF(T1D(K) .lt. 273.15) THEN |
---|
204 | QI1D(K)=QC1D(K) |
---|
205 | QC1D(K)=0. |
---|
206 | QS1D(K)=QR1D(K) |
---|
207 | QR1D(K)=0. |
---|
208 | ENDIF |
---|
209 | ENDDO |
---|
210 | ENDIF |
---|
211 | ENDIF |
---|
212 | |
---|
213 | IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN |
---|
214 | IF (F_QS) THEN |
---|
215 | DO K=kts,kte |
---|
216 | NK=kme-1-K+kms |
---|
217 | QS1D(K)=QS3D(I,NK,J) |
---|
218 | QS1D(K)=max(0.,QS1D(K)) |
---|
219 | ENDDO |
---|
220 | ENDIF |
---|
221 | ENDIF |
---|
222 | |
---|
223 | IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN |
---|
224 | IF (F_QG) THEN |
---|
225 | DO K=kts,kte |
---|
226 | NK=kme-1-K+kms |
---|
227 | QG1D(K)=QG3D(I,NK,J) |
---|
228 | QG1D(K)=max(0.,QG1D(K)) |
---|
229 | ENDDO |
---|
230 | ENDIF |
---|
231 | ENDIF |
---|
232 | |
---|
233 | XLAT0=XLAT(I,J) |
---|
234 | XLONG0=XLONG(I,J) |
---|
235 | ALB0=ALBEDO(I,J) |
---|
236 | |
---|
237 | IF (PRESENT(topo_shading)) THEN |
---|
238 | IF (topo_shading.eq.1) THEN |
---|
239 | do_topo_shading = .TRUE. |
---|
240 | ELSE |
---|
241 | do_topo_shading = .FALSE. |
---|
242 | END IF |
---|
243 | ELSE |
---|
244 | do_topo_shading = .FALSE. |
---|
245 | END IF |
---|
246 | |
---|
247 | shadow = 0 |
---|
248 | IF (do_topo_shading) THEN |
---|
249 | IF(PRESENT(slope_rad) .AND. PRESENT(shadowmask))THEN |
---|
250 | ! Computations for slope-dependent radiation |
---|
251 | |
---|
252 | sinalpha = sina(i,j) |
---|
253 | cosalpha = cosa(i,j) |
---|
254 | |
---|
255 | ! Compute slope and slope azimuth of local grid point |
---|
256 | |
---|
257 | if ((i.ge.ids+1).and.(i.le.ide-2)) then |
---|
258 | hx = (ht(i+1,j)-ht(i-1,j))/(2.*dx) |
---|
259 | else if (i.eq.ids) then |
---|
260 | hx = (ht(i+1,j)-ht(i,j))/dx |
---|
261 | else if (i.eq.ide-1) then |
---|
262 | hx = (ht(i,j)-ht(i-1,j))/dx |
---|
263 | endif |
---|
264 | if ((j.ge.jds+1).and.(j.le.jde-2)) then |
---|
265 | hy = (ht(i,j+1)-ht(i,j-1))/(2.*dy) |
---|
266 | else if (j.eq.jds) then |
---|
267 | hy = (ht(i,j+1)-ht(i,j))/dy |
---|
268 | else if (j.eq.jde-1) then |
---|
269 | hy = (ht(i,j)-ht(i,j-1))/dy |
---|
270 | endif |
---|
271 | |
---|
272 | slope = atan((hx**2+hy**2)**.5) |
---|
273 | if (slope.lt.1.e-4) then |
---|
274 | slope = 0. |
---|
275 | slp_azi = 0. |
---|
276 | else |
---|
277 | slp_azi = atan2(hx,hy)+pi |
---|
278 | ! Rotate slope azimuth to lat-lon grid |
---|
279 | if (cosalpha.ge.0) then |
---|
280 | slp_azi = slp_azi - asin(sinalpha) |
---|
281 | else |
---|
282 | slp_azi = slp_azi - (pi - asin(sinalpha)) |
---|
283 | endif |
---|
284 | endif |
---|
285 | |
---|
286 | shadow = shadowmask(i,j) |
---|
287 | ENDIF |
---|
288 | |
---|
289 | CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, & |
---|
290 | T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, & |
---|
291 | XTIME,GMT,RHO01D,DZ, & |
---|
292 | R,CP,G,DECLIN,SOLCON, & |
---|
293 | COSZ, OMG, & !urban |
---|
294 | RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & |
---|
295 | kts,kte,slope_rad,shadow,slp_azi,slope ) |
---|
296 | ELSE |
---|
297 | CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, & |
---|
298 | T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, & |
---|
299 | XTIME,GMT,RHO01D,DZ, & |
---|
300 | R,CP,G,DECLIN,SOLCON, & |
---|
301 | COSZ, OMG, & !urban |
---|
302 | RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & |
---|
303 | kts,kte ) |
---|
304 | ENDIF |
---|
305 | |
---|
306 | IF (PRESENT(COSZ_URB2D) .AND. PRESENT(OMG_URB2D)) THEN |
---|
307 | COSZ_URB2D(I,J)=COSZ !urban |
---|
308 | OMG_URB2D(I,J)=OMG !urban |
---|
309 | ENDIF |
---|
310 | |
---|
311 | GSW(I,J)=GSW0 |
---|
312 | DO K=kts,kte |
---|
313 | NK=kme-1-K+kms |
---|
314 | RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN1D(NK)/pi3D(I,K,J) |
---|
315 | ENDDO |
---|
316 | ! |
---|
317 | ENDDO i_loop |
---|
318 | ENDDO j_loop |
---|
319 | |
---|
320 | END SUBROUTINE SWRAD |
---|
321 | |
---|
322 | !------------------------------------------------------------------ |
---|
323 | SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO, & |
---|
324 | T,QV,QC,QR,QI,QS,QG,P, & |
---|
325 | XTIME, GMT, RHO0, DZ, & |
---|
326 | R,CP,G,DECLIN,SOLCON, & |
---|
327 | COSZ, OMG, & !urban |
---|
328 | RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & |
---|
329 | kts,kte,slope_rad,shadow,slp_azi,slope ) |
---|
330 | !------------------------------------------------------------------ |
---|
331 | ! TO CALCULATE SHORT-WAVE ABSORPTION AND SCATTERING IN CLEAR |
---|
332 | ! AIR AND REFLECTION AND ABSORPTION IN CLOUD LAYERS (STEPHENS, |
---|
333 | ! 1984) |
---|
334 | ! CHANGES: |
---|
335 | ! REDUCE EFFECTS OF ICE CLOUDS AND PRECIP ON LIQUID WATER PATH |
---|
336 | ! ADD EFFECT OF GRAUPEL |
---|
337 | !------------------------------------------------------------------ |
---|
338 | |
---|
339 | IMPLICIT NONE |
---|
340 | |
---|
341 | INTEGER, INTENT(IN ) :: kts,kte |
---|
342 | ! |
---|
343 | REAL, DIMENSION( kts:kte ), INTENT(IN ) :: & |
---|
344 | RHO0, & |
---|
345 | T, & |
---|
346 | P, & |
---|
347 | DZ, & |
---|
348 | QV, & |
---|
349 | QC, & |
---|
350 | QR, & |
---|
351 | QI, & |
---|
352 | QS, & |
---|
353 | QG |
---|
354 | |
---|
355 | REAL, DIMENSION( kts:kte ), INTENT(INOUT):: TTEN |
---|
356 | ! |
---|
357 | REAL, INTENT(IN ) :: XTIME,GMT,R,CP,G,DECLIN, & |
---|
358 | SOLCON,XLAT,XLONG,ALBEDO, & |
---|
359 | RADFRQ, DEGRAD |
---|
360 | ! |
---|
361 | INTEGER, INTENT(IN) :: icloud |
---|
362 | REAL, INTENT(INOUT) :: GSW |
---|
363 | ! For slope-dependent radiation |
---|
364 | |
---|
365 | INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,shadow |
---|
366 | REAL, OPTIONAL, INTENT(IN) :: slp_azi,slope |
---|
367 | |
---|
368 | ! LOCAL VARS |
---|
369 | ! |
---|
370 | REAL, DIMENSION( kts:kte+1 ) :: SDOWN |
---|
371 | |
---|
372 | REAL, DIMENSION( kts:kte ) :: XLWP, & |
---|
373 | XATP, & |
---|
374 | XWVP, & |
---|
375 | aer_dry1,aer_water1, & |
---|
376 | RO |
---|
377 | ! |
---|
378 | REAL, DIMENSION( 4, 5 ) :: ALBTAB, & |
---|
379 | ABSTAB |
---|
380 | |
---|
381 | REAL, DIMENSION( 4 ) :: XMUVAL |
---|
382 | |
---|
383 | REAL, INTENT(OUT) :: COSZ !urban |
---|
384 | REAL, INTENT(OUT) :: OMG !urban |
---|
385 | |
---|
386 | REAL :: beta |
---|
387 | |
---|
388 | !------------------------------------------------------------------ |
---|
389 | |
---|
390 | DATA ALBTAB/0.,0.,0.,0., & |
---|
391 | 69.,58.,40.,15., & |
---|
392 | 90.,80.,70.,60., & |
---|
393 | 94.,90.,82.,78., & |
---|
394 | 96.,92.,85.,80./ |
---|
395 | |
---|
396 | DATA ABSTAB/0.,0.,0.,0., & |
---|
397 | 0.,2.5,4.,5., & |
---|
398 | 0.,2.6,7.,10., & |
---|
399 | 0.,3.3,10.,14., & |
---|
400 | 0.,3.7,10.,15./ |
---|
401 | |
---|
402 | DATA XMUVAL/0.,0.2,0.5,1.0/ |
---|
403 | |
---|
404 | REAL :: bext340, absc, alba, alw, csza,dabsa,dsca,dabs |
---|
405 | REAL :: bexth2o, dscld, hrang,ff,oldalb,oldabs,oldabc |
---|
406 | REAL :: soltop, totabs, tloctm, ugcm, uv,xabs,xabsa,wv |
---|
407 | REAL :: wgm, xalb, xi, xsca, xt24,xmu,xabsc,trans0,yj |
---|
408 | REAL :: xxlat,ww |
---|
409 | INTEGER :: iil,ii,jjl,ju,k,iu |
---|
410 | |
---|
411 | ! For slope-dependent radiation |
---|
412 | |
---|
413 | REAL :: diffuse_frac, corr_fac, csza_slp |
---|
414 | |
---|
415 | |
---|
416 | GSW=0.0 |
---|
417 | bext340=5.E-6 |
---|
418 | bexth2o=5.E-6 |
---|
419 | SOLTOP=SOLCON |
---|
420 | XT24=MOD(XTIME+RADFRQ*0.5,1440.) |
---|
421 | TLOCTM=GMT+XT24/60.+XLONG/15. |
---|
422 | HRANG=15.*(TLOCTM-12.)*DEGRAD |
---|
423 | XXLAT=XLAT*DEGRAD |
---|
424 | CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG) |
---|
425 | |
---|
426 | COSZ = CSZA !urban |
---|
427 | OMG = HRANG !urban |
---|
428 | |
---|
429 | ! RETURN IF NIGHT |
---|
430 | IF(CSZA.LE.1.E-9)GOTO 7 |
---|
431 | ! |
---|
432 | DO K=kts, kte |
---|
433 | |
---|
434 | ! P in the unit of 10mb |
---|
435 | RO(K)=P(K)/(R*T(K)) |
---|
436 | XWVP(K)=RO(K)*QV(K)*DZ(K)*1000. |
---|
437 | ! KG/M**2 |
---|
438 | XATP(K)=RO(K)*DZ(K) |
---|
439 | ENDDO |
---|
440 | ! |
---|
441 | ! G/M**2 |
---|
442 | ! REDUCE WEIGHT OF LIQUID AND ICE IN SHORT-WAVE SCHEME |
---|
443 | ! ADD GRAUPEL EFFECT (ASSUMED SAME AS RAIN) |
---|
444 | ! |
---|
445 | IF (ICLOUD.EQ.0)THEN |
---|
446 | DO K=kts, kte |
---|
447 | XLWP(K)=0. |
---|
448 | ENDDO |
---|
449 | ELSE |
---|
450 | DO K=kts, kte |
---|
451 | XLWP(K)=RO(K)*1000.*DZ(K)*(QC(K)+0.1*QI(K)+0.05* & |
---|
452 | QR(K)+0.02*QS(K)+0.05*QG(K)) |
---|
453 | ENDDO |
---|
454 | ENDIF |
---|
455 | ! |
---|
456 | XMU=CSZA |
---|
457 | SDOWN(1)=SOLTOP*XMU |
---|
458 | ! SET WW (G/M**2) LIQUID WATER PATH INTEGRATED DOWN |
---|
459 | ! SET UV (G/M**2) WATER VAPOR PATH INTEGRATED DOWN |
---|
460 | WW=0. |
---|
461 | UV=0. |
---|
462 | OLDALB=0. |
---|
463 | OLDABC=0. |
---|
464 | TOTABS=0. |
---|
465 | ! CONTRIBUTIONS DUE TO CLEAR AIR AND CLOUD |
---|
466 | DSCA=0. |
---|
467 | DABS=0. |
---|
468 | DSCLD=0. |
---|
469 | ! |
---|
470 | ! CONTRIBUTION DUE TO AEROSOLS (FOR CHEMISTRY) |
---|
471 | DABSA=0. |
---|
472 | ! |
---|
473 | DO 200 K=kts,kte |
---|
474 | WW=WW+XLWP(K) |
---|
475 | UV=UV+XWVP(K) |
---|
476 | ! WGM IS WW/COS(THETA) (G/M**2) |
---|
477 | ! UGCM IS UV/COS(THETA) (G/CM**2) |
---|
478 | WGM=WW/XMU |
---|
479 | UGCM=UV*0.0001/XMU |
---|
480 | ! |
---|
481 | OLDABS=TOTABS |
---|
482 | ! WATER VAPOR ABSORPTION AS IN LACIS AND HANSEN (1974) |
---|
483 | TOTABS=2.9*UGCM/((1.+141.5*UGCM)**0.635+5.925*UGCM) |
---|
484 | ! APPROXIMATE RAYLEIGH + AEROSOL SCATTERING |
---|
485 | ! XSCA=1.E-5*XATP(K)/XMU |
---|
486 | ! XSCA=(1.E-5*XATP(K)+aer_dry1(K)*bext340+aer_water1(K)*bexth2o)/XMU |
---|
487 | beta=0.4*(1.0-XMU)+0.1 |
---|
488 | ! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT |
---|
489 | XSCA=(cssca*XATP(K)+beta*aer_dry1(K)*bext340*DZ(K) & |
---|
490 | +beta*aer_water1(K)*bexth2o*DZ(K))/XMU |
---|
491 | |
---|
492 | ! LAYER VAPOR ABSORPTION DONE FIRST |
---|
493 | XABS=(TOTABS-OLDABS)*(SDOWN(1)-DSCLD-DSCA-DABSA)/SDOWN(K) |
---|
494 | !rs AEROSOL ABSORB (would be elemental carbon). So far XABSA = 0. |
---|
495 | XABSA=0. |
---|
496 | IF(XABS.LT.0.)XABS=0. |
---|
497 | ! |
---|
498 | ALW=ALOG10(WGM+1.) |
---|
499 | IF(ALW.GT.3.999)ALW=3.999 |
---|
500 | ! |
---|
501 | DO II=1,3 |
---|
502 | IF(XMU.GT.XMUVAL(II))THEN |
---|
503 | IIL=II |
---|
504 | IU=II+1 |
---|
505 | XI=(XMU-XMUVAL(II))/(XMUVAL(II+1)-XMUVAL(II))+FLOAT(IIL) |
---|
506 | ENDIF |
---|
507 | ENDDO |
---|
508 | ! |
---|
509 | JJL=IFIX(ALW)+1 |
---|
510 | JU=JJL+1 |
---|
511 | YJ=ALW+1. |
---|
512 | ! CLOUD ALBEDO |
---|
513 | ALBA=(ALBTAB(IU,JU)*(XI-IIL)*(YJ-JJL) & |
---|
514 | +ALBTAB(IIL,JU)*(IU-XI)*(YJ-JJL) & |
---|
515 | +ALBTAB(IU,JJL)*(XI-IIL)*(JU-YJ) & |
---|
516 | +ALBTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) & |
---|
517 | /((IU-IIL)*(JU-JJL)) |
---|
518 | ! CLOUD ABSORPTION |
---|
519 | ABSC=(ABSTAB(IU,JU)*(XI-IIL)*(YJ-JJL) & |
---|
520 | +ABSTAB(IIL,JU)*(IU-XI)*(YJ-JJL) & |
---|
521 | +ABSTAB(IU,JJL)*(XI-IIL)*(JU-YJ) & |
---|
522 | +ABSTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) & |
---|
523 | /((IU-IIL)*(JU-JJL)) |
---|
524 | ! LAYER ALBEDO AND ABSORPTION |
---|
525 | XALB=(ALBA-OLDALB)*(SDOWN(1)-DSCA-DABS)/SDOWN(K) |
---|
526 | XABSC=(ABSC-OLDABC)*(SDOWN(1)-DSCA-DABS)/SDOWN(K) |
---|
527 | IF(XALB.LT.0.)XALB=0. |
---|
528 | IF(XABSC.LT.0.)XABSC=0. |
---|
529 | DSCLD=DSCLD+(XALB+XABSC)*SDOWN(K)*0.01 |
---|
530 | DSCA=DSCA+XSCA*SDOWN(K) |
---|
531 | DABS=DABS+XABS*SDOWN(K) |
---|
532 | DABSA=DABSA+XABSA*SDOWN(K) |
---|
533 | OLDALB=ALBA |
---|
534 | OLDABC=ABSC |
---|
535 | ! LAYER TRANSMISSIVITY |
---|
536 | TRANS0=100.-XALB-XABSC-XABS*100.-XSCA*100. |
---|
537 | IF(TRANS0.LT.1.)THEN |
---|
538 | FF=99./(XALB+XABSC+XABS*100.+XSCA*100.) |
---|
539 | XALB=XALB*FF |
---|
540 | XABSC=XABSC*FF |
---|
541 | XABS=XABS*FF |
---|
542 | XSCA=XSCA*FF |
---|
543 | TRANS0=1. |
---|
544 | ENDIF |
---|
545 | SDOWN(K+1)=AMAX1(1.E-9,SDOWN(K)*TRANS0*0.01) |
---|
546 | TTEN(K)=SDOWN(K)*(XABSC+XABS*100.+XABSA*100.)*0.01/( & |
---|
547 | RO(K)*CP*DZ(K)) |
---|
548 | 200 CONTINUE |
---|
549 | ! |
---|
550 | GSW=(1.-ALBEDO)*SDOWN(kte+1) |
---|
551 | |
---|
552 | IF (PRESENT(slope_rad)) THEN |
---|
553 | ! Slope-dependent solar radiation part |
---|
554 | |
---|
555 | if (slope_rad.eq.1) then |
---|
556 | |
---|
557 | ! Parameterize diffuse fraction of global solar radiation as a function of the ratio between TOA radiation and surface global radiation |
---|
558 | |
---|
559 | diffuse_frac = min(1.,1/(max(0.1,2.1-2.8*log(log(SDOWN(kts)/max(SDOWN(kte+1),1.e-3)))))) |
---|
560 | if ((slope.eq.0).or.(diffuse_frac.eq.1).or.(csza.lt.1.e-2)) then ! no topographic effects when all radiation is diffuse or the sun is too close to the horizon |
---|
561 | corr_fac = 1 |
---|
562 | goto 140 |
---|
563 | endif |
---|
564 | |
---|
565 | ! cosine of zenith angle over sloping topography |
---|
566 | |
---|
567 | csza_slp = ((SIN(XXLAT)*COS(HRANG))* & |
---|
568 | (-cos(slp_azi)*sin(slope))-SIN(HRANG)*(sin(slp_azi)*sin(slope))+ & |
---|
569 | (COS(XXLAT)*COS(HRANG))*cos(slope))* & |
---|
570 | COS(DECLIN)+(COS(XXLAT)*(cos(slp_azi)*sin(slope))+ & |
---|
571 | SIN(XXLAT)*cos(slope))*SIN(DECLIN) |
---|
572 | IF(csza_slp.LE.1.E-4) csza_slp = 0 |
---|
573 | |
---|
574 | ! Topographic shading |
---|
575 | |
---|
576 | if (shadow.eq.1) csza_slp = 0 |
---|
577 | |
---|
578 | ! Correction factor for sloping topography; the diffuse fraction of solar radiation is assumed to be unaffected by the slope |
---|
579 | corr_fac = diffuse_frac + (1-diffuse_frac)*csza_slp/csza |
---|
580 | |
---|
581 | 140 continue |
---|
582 | |
---|
583 | GSW=(1.-ALBEDO)*SDOWN(kte+1)*corr_fac |
---|
584 | |
---|
585 | endif |
---|
586 | ENDIF |
---|
587 | |
---|
588 | 7 CONTINUE |
---|
589 | ! |
---|
590 | END SUBROUTINE SWPARA |
---|
591 | |
---|
592 | !==================================================================== |
---|
593 | SUBROUTINE swinit(swrad_scat, & |
---|
594 | allowed_to_read , & |
---|
595 | ids, ide, jds, jde, kds, kde, & |
---|
596 | ims, ime, jms, jme, kms, kme, & |
---|
597 | its, ite, jts, jte, kts, kte ) |
---|
598 | !-------------------------------------------------------------------- |
---|
599 | IMPLICIT NONE |
---|
600 | !-------------------------------------------------------------------- |
---|
601 | LOGICAL , INTENT(IN) :: allowed_to_read |
---|
602 | INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & |
---|
603 | ims, ime, jms, jme, kms, kme, & |
---|
604 | its, ite, jts, jte, kts, kte |
---|
605 | |
---|
606 | REAL , INTENT(IN) :: swrad_scat |
---|
607 | |
---|
608 | ! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT |
---|
609 | cssca = swrad_scat * 1.e-5 |
---|
610 | |
---|
611 | END SUBROUTINE swinit |
---|
612 | |
---|
613 | END MODULE module_ra_sw |
---|