module_ra_sw.F
References to this file elsewhere.
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 cosz_urb2d,omg_urb2d & !Optional urban
22 )
23 !------------------------------------------------------------------
24 IMPLICIT NONE
25 !------------------------------------------------------------------
26 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
27 ims,ime, jms,jme, kms,kme, &
28 its,ite, jts,jte, kts,kte
29
30 LOGICAL, INTENT(IN ) :: warm_rain
31 INTEGER, INTENT(IN ) :: icloud
32
33 REAL, INTENT(IN ) :: RADFRQ,DEGRAD, &
34 XTIME,DECLIN,SOLCON
35 !
36 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
37 INTENT(IN ) :: P3D, &
38 pi3D, &
39 rho_phy, &
40 dz8w, &
41 T3D
42 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
43 INTENT(IN ) :: pm2_5_dry, &
44 pm2_5_water, &
45 pm2_5_dry_ec
46
47
48 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
49 INTENT(INOUT) :: RTHRATEN
50 !
51 REAL, DIMENSION( ims:ime, jms:jme ), &
52 INTENT(IN ) :: XLAT, &
53 XLONG, &
54 ALBEDO
55 !
56 REAL, DIMENSION( ims:ime, jms:jme ), &
57 INTENT(INOUT) :: GSW
58 !
59 REAL, INTENT(IN ) :: GMT,R,CP,G,dt
60 !
61 INTEGER, INTENT(IN ) :: JULDAY
62 !
63 ! Optional
64 !
65 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
66 OPTIONAL, &
67 INTENT(IN ) :: &
68 QV3D, &
69 QC3D, &
70 QR3D, &
71 QI3D, &
72 QS3D, &
73 QG3D
74
75 LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
76
77 ! LOCAL VARS
78
79 REAL, DIMENSION( kts:kte ) :: &
80 TTEN1D, &
81 RHO01D, &
82 P1D, &
83 DZ, &
84 T1D, &
85 QV1D, &
86 QC1D, &
87 QR1D, &
88 QI1D, &
89 QS1D, &
90 QG1D
91 !
92 REAL:: XLAT0,XLONG0,ALB0,GSW0
93
94 REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D, OMG_URB2D !Optional urban
95 REAL :: COSZ, OMG !urban
96 !
97 INTEGER :: i,j,K,NK
98 LOGICAL :: predicate
99 real :: aer_dry1(kts:kte),aer_water1(kts:kte)
100
101 !------------------------------------------------------------------
102 j_loop: DO J=jts,jte
103 i_loop: DO I=its,ite
104
105 ! reverse vars
106 DO K=kts,kte
107 QV1D(K)=0.
108 QC1D(K)=0.
109 QR1D(K)=0.
110 QI1D(K)=0.
111 QS1D(K)=0.
112 QG1D(K)=0.
113 ENDDO
114
115 DO K=kts,kte
116 NK=kme-1-K+kms
117 TTEN1D(K)=0.
118
119 T1D(K)=T3D(I,NK,J)
120 P1D(K)=P3D(I,NK,J)
121 RHO01D(K)=rho_phy(I,NK,J)
122 DZ(K)=dz8w(I,NK,J)
123 ENDDO
124
125 IF( PRESENT(pm2_5_dry) .AND. PRESENT(pm2_5_water) )THEN
126 DO K=kts,kte
127 NK=kme-1-K+kms
128 aer_dry1(k) = pm2_5_dry(i,nk,j)
129 aer_water1(k) = pm2_5_water(i,nk,j)
130 ENDDO
131 ELSE
132 DO K=kts,kte
133 aer_dry1(k) = 0.
134 aer_water1(k) = 0.
135 ENDDO
136 ENDIF
137
138 IF (PRESENT(F_QV) .AND. PRESENT(QV3D)) THEN
139 IF (F_QV) THEN
140 DO K=kts,kte
141 NK=kme-1-K+kms
142 QV1D(K)=QV3D(I,NK,J)
143 QV1D(K)=max(0.,QV1D(K))
144 ENDDO
145 ENDIF
146 ENDIF
147
148 IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
149 IF (F_QC) THEN
150 DO K=kts,kte
151 NK=kme-1-K+kms
152 QC1D(K)=QC3D(I,NK,J)
153 QC1D(K)=max(0.,QC1D(K))
154 ENDDO
155 ENDIF
156 ENDIF
157
158 IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
159 IF (F_QR) THEN
160 DO K=kts,kte
161 NK=kme-1-K+kms
162 QR1D(K)=QR3D(I,NK,J)
163 QR1D(K)=max(0.,QR1D(K))
164 ENDDO
165 ENDIF
166 ENDIF
167
168 !
169 IF ( PRESENT( F_QI ) ) THEN
170 predicate = F_QI
171 ELSE
172 predicate = .FALSE.
173 ENDIF
174
175 IF ( predicate .AND. PRESENT( QI3D ) ) THEN
176 DO K=kts,kte
177 NK=kme-1-K+kms
178 QI1D(K)=QI3D(I,NK,J)
179 QI1D(K)=max(0.,QI1D(K))
180 ENDDO
181 ELSE
182 IF (.not. warm_rain) THEN
183 DO K=kts,kte
184 IF(T1D(K) .lt. 273.15) THEN
185 QI1D(K)=QC1D(K)
186 QC1D(K)=0.
187 QS1D(K)=QR1D(K)
188 QR1D(K)=0.
189 ENDIF
190 ENDDO
191 ENDIF
192 ENDIF
193
194 IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
195 IF (F_QS) THEN
196 DO K=kts,kte
197 NK=kme-1-K+kms
198 QS1D(K)=QS3D(I,NK,J)
199 QS1D(K)=max(0.,QS1D(K))
200 ENDDO
201 ENDIF
202 ENDIF
203
204 IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
205 IF (F_QG) THEN
206 DO K=kts,kte
207 NK=kme-1-K+kms
208 QG1D(K)=QG3D(I,NK,J)
209 QG1D(K)=max(0.,QG1D(K))
210 ENDDO
211 ENDIF
212 ENDIF
213
214 XLAT0=XLAT(I,J)
215 XLONG0=XLONG(I,J)
216 ALB0=ALBEDO(I,J)
217
218 CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, &
219 T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, &
220 XTIME,GMT,RHO01D,DZ, &
221 R,CP,G,DECLIN,SOLCON, &
222 COSZ, OMG, & !urban
223 RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
224 kts,kte )
225
226 IF (PRESENT(COSZ_URB2D) .AND. PRESENT(OMG_URB2D)) THEN
227 COSZ_URB2D(I,J)=COSZ !urban
228 OMG_URB2D(I,J)=OMG !urban
229 ENDIF
230
231 GSW(I,J)=GSW0
232 DO K=kts,kte
233 NK=kme-1-K+kms
234 RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN1D(NK)/pi3D(I,K,J)
235 ENDDO
236 !
237 ENDDO i_loop
238 ENDDO j_loop
239
240 END SUBROUTINE SWRAD
241
242 !------------------------------------------------------------------
243 SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO, &
244 T,QV,QC,QR,QI,QS,QG,P, &
245 XTIME, GMT, RHO0, DZ, &
246 R,CP,G,DECLIN,SOLCON, &
247 COSZ, OMG, & !urban
248 RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
249 kts,kte )
250 !------------------------------------------------------------------
251 ! TO CALCULATE SHORT-WAVE ABSORPTION AND SCATTERING IN CLEAR
252 ! AIR AND REFLECTION AND ABSORPTION IN CLOUD LAYERS (STEPHENS,
253 ! 1984)
254 ! CHANGES:
255 ! REDUCE EFFECTS OF ICE CLOUDS AND PRECIP ON LIQUID WATER PATH
256 ! ADD EFFECT OF GRAUPEL
257 !------------------------------------------------------------------
258
259 IMPLICIT NONE
260
261 INTEGER, INTENT(IN ) :: kts,kte
262 !
263 REAL, DIMENSION( kts:kte ), INTENT(IN ) :: &
264 RHO0, &
265 T, &
266 P, &
267 DZ, &
268 QV, &
269 QC, &
270 QR, &
271 QI, &
272 QS, &
273 QG
274
275 REAL, DIMENSION( kts:kte ), INTENT(INOUT):: TTEN
276 !
277 REAL, INTENT(IN ) :: XTIME,GMT,R,CP,G,DECLIN, &
278 SOLCON,XLAT,XLONG,ALBEDO, &
279 RADFRQ, DEGRAD
280 !
281 INTEGER, INTENT(IN) :: icloud
282 REAL, INTENT(INOUT) :: GSW
283 !
284 ! LOCAL VARS
285 !
286 REAL, DIMENSION( kts:kte+1 ) :: SDOWN
287
288 REAL, DIMENSION( kts:kte ) :: XLWP, &
289 XATP, &
290 XWVP, &
291 aer_dry1,aer_water1, &
292 RO
293 !
294 REAL, DIMENSION( 4, 5 ) :: ALBTAB, &
295 ABSTAB
296
297 REAL, DIMENSION( 4 ) :: XMUVAL
298
299 REAL, INTENT(OUT) :: COSZ !urban
300 REAL, INTENT(OUT) :: OMG !urban
301
302 REAL :: beta
303
304 !------------------------------------------------------------------
305
306 DATA ALBTAB/0.,0.,0.,0., &
307 69.,58.,40.,15., &
308 90.,80.,70.,60., &
309 94.,90.,82.,78., &
310 96.,92.,85.,80./
311
312 DATA ABSTAB/0.,0.,0.,0., &
313 0.,2.5,4.,5., &
314 0.,2.6,7.,10., &
315 0.,3.3,10.,14., &
316 0.,3.7,10.,15./
317
318 DATA XMUVAL/0.,0.2,0.5,1.0/
319
320 REAL :: bext340, absc, alba, alw, csza,dabsa,dsca,dabs
321 REAL :: bexth2o, dscld, hrang,ff,oldalb,oldabs,oldabc
322 REAL :: soltop, totabs, tloctm, ugcm, uv,xabs,xabsa,wv
323 REAL :: wgm, xalb, xi, xsca, xt24,xmu,xabsc,trans0,yj
324 REAL :: xxlat,ww
325 INTEGER :: iil,ii,jjl,ju,k,iu
326
327 GSW=0.0
328 bext340=5.E-6
329 bexth2o=5.E-6
330 SOLTOP=SOLCON
331 XT24=MOD(XTIME+RADFRQ*0.5,1440.)
332 TLOCTM=GMT+XT24/60.+XLONG/15.
333 HRANG=15.*(TLOCTM-12.)*DEGRAD
334 XXLAT=XLAT*DEGRAD
335 CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
336
337 COSZ = CSZA !urban
338 OMG = HRANG !urban
339
340 ! RETURN IF NIGHT
341 IF(CSZA.LE.1.E-9)GOTO 7
342 !
343 DO K=kts, kte
344
345 ! P in the unit of 10mb
346 RO(K)=P(K)/(R*T(K))
347 XWVP(K)=RO(K)*QV(K)*DZ(K)*1000.
348 ! KG/M**2
349 XATP(K)=RO(K)*DZ(K)
350 ENDDO
351 !
352 ! G/M**2
353 ! REDUCE WEIGHT OF LIQUID AND ICE IN SHORT-WAVE SCHEME
354 ! ADD GRAUPEL EFFECT (ASSUMED SAME AS RAIN)
355 !
356 IF (ICLOUD.EQ.0)THEN
357 DO K=kts, kte
358 XLWP(K)=0.
359 ENDDO
360 ELSE
361 DO K=kts, kte
362 XLWP(K)=RO(K)*1000.*DZ(K)*(QC(K)+0.1*QI(K)+0.05* &
363 QR(K)+0.02*QS(K)+0.05*QG(K))
364 ENDDO
365 ENDIF
366 !
367 XMU=CSZA
368 SDOWN(1)=SOLTOP*XMU
369 ! SET WW (G/M**2) LIQUID WATER PATH INTEGRATED DOWN
370 ! SET UV (G/M**2) WATER VAPOR PATH INTEGRATED DOWN
371 WW=0.
372 UV=0.
373 OLDALB=0.
374 OLDABC=0.
375 TOTABS=0.
376 ! CONTRIBUTIONS DUE TO CLEAR AIR AND CLOUD
377 DSCA=0.
378 DABS=0.
379 DSCLD=0.
380 !
381 ! CONTRIBUTION DUE TO AEROSOLS (FOR CHEMISTRY)
382 DABSA=0.
383 !
384 DO 200 K=kts,kte
385 WW=WW+XLWP(K)
386 UV=UV+XWVP(K)
387 ! WGM IS WW/COS(THETA) (G/M**2)
388 ! UGCM IS UV/COS(THETA) (G/CM**2)
389 WGM=WW/XMU
390 UGCM=UV*0.0001/XMU
391 !
392 OLDABS=TOTABS
393 ! WATER VAPOR ABSORPTION AS IN LACIS AND HANSEN (1974)
394 TOTABS=2.9*UGCM/((1.+141.5*UGCM)**0.635+5.925*UGCM)
395 ! APPROXIMATE RAYLEIGH + AEROSOL SCATTERING
396 ! XSCA=1.E-5*XATP(K)/XMU
397 ! XSCA=(1.E-5*XATP(K)+aer_dry1(K)*bext340+aer_water1(K)*bexth2o)/XMU
398 beta=0.4*(1.0-XMU)+0.1
399 ! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT
400 XSCA=(cssca*XATP(K)+beta*aer_dry1(K)*bext340*DZ(K) &
401 +beta*aer_water1(K)*bexth2o*DZ(K))/XMU
402
403 ! LAYER VAPOR ABSORPTION DONE FIRST
404 XABS=(TOTABS-OLDABS)*(SDOWN(1)-DSCLD-DSCA-DABSA)/SDOWN(K)
405 !rs AEROSOL ABSORB (would be elemental carbon). So far XABSA = 0.
406 XABSA=0.
407 IF(XABS.LT.0.)XABS=0.
408 !
409 ALW=ALOG10(WGM+1.)
410 IF(ALW.GT.3.999)ALW=3.999
411 !
412 DO II=1,3
413 IF(XMU.GT.XMUVAL(II))THEN
414 IIL=II
415 IU=II+1
416 XI=(XMU-XMUVAL(II))/(XMUVAL(II+1)-XMUVAL(II))+FLOAT(IIL)
417 ENDIF
418 ENDDO
419 !
420 JJL=IFIX(ALW)+1
421 JU=JJL+1
422 YJ=ALW+1.
423 ! CLOUD ALBEDO
424 ALBA=(ALBTAB(IU,JU)*(XI-IIL)*(YJ-JJL) &
425 +ALBTAB(IIL,JU)*(IU-XI)*(YJ-JJL) &
426 +ALBTAB(IU,JJL)*(XI-IIL)*(JU-YJ) &
427 +ALBTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) &
428 /((IU-IIL)*(JU-JJL))
429 ! CLOUD ABSORPTION
430 ABSC=(ABSTAB(IU,JU)*(XI-IIL)*(YJ-JJL) &
431 +ABSTAB(IIL,JU)*(IU-XI)*(YJ-JJL) &
432 +ABSTAB(IU,JJL)*(XI-IIL)*(JU-YJ) &
433 +ABSTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) &
434 /((IU-IIL)*(JU-JJL))
435 ! LAYER ALBEDO AND ABSORPTION
436 XALB=(ALBA-OLDALB)*(SDOWN(1)-DSCA-DABS)/SDOWN(K)
437 XABSC=(ABSC-OLDABC)*(SDOWN(1)-DSCA-DABS)/SDOWN(K)
438 IF(XALB.LT.0.)XALB=0.
439 IF(XABSC.LT.0.)XABSC=0.
440 DSCLD=DSCLD+(XALB+XABSC)*SDOWN(K)*0.01
441 DSCA=DSCA+XSCA*SDOWN(K)
442 DABS=DABS+XABS*SDOWN(K)
443 DABSA=DABSA+XABSA*SDOWN(K)
444 OLDALB=ALBA
445 OLDABC=ABSC
446 ! LAYER TRANSMISSIVITY
447 TRANS0=100.-XALB-XABSC-XABS*100.-XSCA*100.
448 IF(TRANS0.LT.1.)THEN
449 FF=99./(XALB+XABSC+XABS*100.+XSCA*100.)
450 XALB=XALB*FF
451 XABSC=XABSC*FF
452 XABS=XABS*FF
453 XSCA=XSCA*FF
454 TRANS0=1.
455 ENDIF
456 SDOWN(K+1)=AMAX1(1.E-9,SDOWN(K)*TRANS0*0.01)
457 TTEN(K)=SDOWN(K)*(XABSC+XABS*100.+XABSA*100.)*0.01/( &
458 RO(K)*CP*DZ(K))
459 200 CONTINUE
460 !
461 GSW=(1.-ALBEDO)*SDOWN(kte+1)
462
463 7 CONTINUE
464 !
465 END SUBROUTINE SWPARA
466
467 !====================================================================
468 SUBROUTINE swinit(swrad_scat, &
469 allowed_to_read , &
470 ids, ide, jds, jde, kds, kde, &
471 ims, ime, jms, jme, kms, kme, &
472 its, ite, jts, jte, kts, kte )
473 !--------------------------------------------------------------------
474 IMPLICIT NONE
475 !--------------------------------------------------------------------
476 LOGICAL , INTENT(IN) :: allowed_to_read
477 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
478 ims, ime, jms, jme, kms, kme, &
479 its, ite, jts, jte, kts, kte
480
481 REAL , INTENT(IN) :: swrad_scat
482
483 ! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT
484 cssca = swrad_scat * 1.e-5
485
486 END SUBROUTINE swinit
487
488 END MODULE module_ra_sw