52 SUBROUTINE swrad(dt,RTHRATEN,SDOWN3D,GSW,XLAT,XLONG,ALBEDO, &
53 rho_phy,T3D,P3D,pi3D,dz8w, &
55 QV3D,QC3D,QR3D,QI3D,QS3D,QG3D, &
56 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, &
69 real(
dp),
INTENT(IN) :: dt
70 real(rp),
INTENT(INOUT) :: rthraten(
ia,
ka,
ja)
71 real(rp),
INTENT(INOUT) :: sdown3d(
ia,
ka,
ja)
72 real(rp),
INTENT(INOUT) :: gsw(
ia,
ja)
74 real(rp),
INTENT(IN) :: xlat(
ia,
ja), xlong(
ia,
ja), albedo(
ia,
ja)
75 real(rp),
INTENT(IN) :: rho_phy(
ia,
ka,
ja)
76 real(rp),
INTENT(IN) :: p3d(
ia,
ka,
ja), &
80 real(rp),
INTENT(IN) :: solins(
ia,
ja),cossza(
ia,
ja)
81 real(rp),
OPTIONAL,
INTENT(IN) :: qv3d (
ia,
ka,
ja), &
88 LOGICAL,
OPTIONAL,
INTENT(IN ) :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg
89 INTEGER,
INTENT(IN ) :: icloud
90 LOGICAL,
INTENT(IN ) :: warm_rain
95 integer :: its,ite,jts,jte,kts,kte
96 real(rp) :: r, cp, g, solcon
100 real(rp),
DIMENSION( KS:KE ) :: tten1d, &
112 real(rp) :: sdown1d(
ks:
ke+1)
114 real(rp) :: xlat0,xlong0,alb0,gsw0,cossza0,solins0
115 real(rp) :: aer_dry1(
ks:
ke),aer_water1(
ks:
ke)
119 LOGICAL :: predicate , do_topo_shading
153 rho01d(
k)=rho_phy(i,nk,j)
170 IF (
PRESENT(f_qv) .AND.
PRESENT(qv3d))
THEN
176 qv1d(
k)=max(0.0_rp,qv1d(
k))
181 IF (
PRESENT(f_qc) .AND.
PRESENT(qc3d))
THEN
187 qc1d(
k)=max(0.0_rp,qc1d(
k))
192 IF (
PRESENT(f_qr) .AND.
PRESENT(qr3d))
THEN
198 qr1d(
k)=max(0.0_rp,qr1d(
k))
204 IF (
PRESENT( f_qi ) )
THEN
210 IF ( predicate .AND.
PRESENT( qi3d ) )
THEN
215 qi1d(
k)=max(0.0_rp,qi1d(
k))
218 IF (.NOT. warm_rain)
THEN
220 IF(t1d(
k) < 273.15)
THEN
230 IF (
PRESENT(f_qs) .AND.
PRESENT(qs3d))
THEN
236 qs1d(
k)=max(0.0_rp,qs1d(
k))
241 IF (
PRESENT(f_qg) .AND.
PRESENT(qg3d))
THEN
247 qg1d(
k)=max(0.0_rp,qg1d(
k))
258 CALL swpara(tten1d,sdown1d,gsw0,alb0,cossza0, &
259 t1d,qv1d,qc1d,qr1d,qi1d,qs1d,qg1d,p1d, &
263 icloud,aer_dry1,aer_water1, &
280 rthraten(i,
k,j)=rthraten(i,
k,j)+tten1d(nk)/pi3d(i,
k,j)
281 sdown3d(i,
k,j)=sdown1d(nk)
285 sdown3d(i,
ks-1,j)=sdown1d(
ke+1)
295 SUBROUTINE swpara(TTEN,SDOWN,GSW,ALBEDO,cosSZA, &
296 T,QV,QC,QR,QI,QS,QG,P, &
300 ICLOUD,aer_dry1,aer_water1, &
304 nowdate =>
time_nowdate !< current time [yyyy mm dd hh mm ss]
317 INTEGER,
INTENT(IN ) :: kts,kte
319 real(RP),
DIMENSION( kts:kte ),
INTENT(IN ) :: &
331 real(RP),
DIMENSION( kts:kte ),
INTENT(INOUT) :: TTEN
332 real(RP),
DIMENSION( kts:kte+1 ),
INTENT(OUT) :: SDOWN
334 real(RP),
INTENT(IN ) :: R,CP,G
335 real(RP),
INTENT(IN) :: ALBEDO,cosSZA,solins
336 integer ,
INTENT(IN) :: icloud
337 real(RP),
INTENT(INOUT) :: GSW
338 real(RP),
INTENT(IN ) :: XXLAT,XXLON
349 real(RP) :: XLWP( kts:kte )
350 real(RP) :: XATP( kts:kte )
351 real(RP) :: XWVP( kts:kte )
352 real(RP) :: aer_dry1( kts:kte )
353 real(RP) :: aer_water1( kts:kte )
354 real(RP) :: RO( kts:kte )
356 real(RP) :: ALBTAB(4,5), ABSTAB(4,5)
357 real(RP) :: XMUVAL(4)
360 real(RP) :: DayOfYear
363 DATA albtab/0.0,0.0,0.0,0.0, &
364 69.0,58.0,40.0,15.0, &
365 90.0,80.0,70.0,60.0, &
366 94.0,90.0,82.0,78.0, &
369 DATA abstab/0.0,0.0,0.0,0.0, &
375 DATA xmuval/0.0,0.2,0.5,1.0/
377 real(RP) :: bext340, absc, alba, alw, csza,dabsa,dsca,dabs
378 real(RP) :: bexth2o, dscld, ff,oldalb,oldabs,oldabc
379 real(RP) :: soltop, totabs, ugcm, uv,xabs,xabsa,wv
380 real(RP) :: wgm, xalb, xi, xsca, xmu,xabsc,trans0,yj
381 real(RP) :: HRANG,XT24,TLOCTM,tloc,dsec,lon,lat
384 INTEGER :: iil,ii,jjl,ju,k,iu
388 real(RP) :: diffuse_frac, corr_fac, csza_slp
406 tloc = mod((nowdate(4) + int(lon/15.0_rp)),24 )
407 dsec = real(nowdate(5)*60 + nowdate(6)) / 60.0_rp /60.0_rp
408 tloctm = real(nowdate(4)) + lon/15.0_rp + dsec
409 hrang = 15.*(tloctm-12.)*d2r
414 IF(csza <= 1.0e-9_rp)
GOTO 7
420 xwvp(k)=ro(k)*qv(k)*dz(k)*1000.
435 xlwp(k)=ro(k)*1000.*dz(k)*(qc(k)+0.1*qi(k)+0.05* &
436 qr(k)+0.02*qs(k)+0.05*qg(k))
443 sdown(kts)=soltop * max(cossza,0.0_rp)
470 totabs=2.9*ugcm/((1.+141.5*ugcm)**0.635+5.925*ugcm)
474 beta=0.4*(1.0-xmu)+0.1
476 xsca=(cssca*xatp(k)+beta*aer_dry1(k)*bext340*dz(k) &
477 +beta*aer_water1(k)*bexth2o*dz(k))/xmu
481 xabs=(totabs-oldabs)*(sdown(kts)-dscld-dsca-dabsa)/sdown(k)
486 alw=log10(wgm+1.0_rp)
487 IF(alw>3.999)alw=3.999_rp
490 IF(xmu>xmuval(ii))
THEN
493 xi=(xmu-xmuval(ii))/(xmuval(ii+1)-xmuval(ii))+
float(iil)
501 alba=(albtab(iu,ju)*(xi-iil)*(yj-jjl) &
502 +albtab(iil,ju)*(iu-xi)*(yj-jjl) &
503 +albtab(iu,jjl)*(xi-iil)*(ju-yj) &
504 +albtab(iil,jjl)*(iu-xi)*(ju-yj)) &
507 absc=(abstab(iu,ju)*(xi-iil)*(yj-jjl) &
508 +abstab(iil,ju)*(iu-xi)*(yj-jjl) &
509 +abstab(iu,jjl)*(xi-iil)*(ju-yj) &
510 +abstab(iil,jjl)*(iu-xi)*(ju-yj)) &
515 xalb=(alba-oldalb)*(sdown(kts)-dsca-dabs)/sdown(k)
516 xabsc=(absc-oldabc)*(sdown(kts)-dsca-dabs)/sdown(k)
519 dscld=dscld+(xalb+xabsc)*sdown(k)*0.01
520 dsca=dsca+xsca*sdown(k)
521 dabs=dabs+xabs*sdown(k)
522 dabsa=dabsa+xabsa*sdown(k)
526 trans0=100.0_rp-xalb-xabsc-xabs*100.0_rp-xsca*100.0_rp
528 ff=99.0_rp/(xalb+xabsc+xabs*100.0_rp+xsca*100.0_rp)
535 sdown(k+1)=max(1.0e-9_rp,sdown(k)*trans0*0.01_rp)
536 tten(k)=sdown(k)*(xabsc+xabs*100._rp+xabsa*100._rp)*0.01_rp/(ro(k)*cp*dz(k))
539 gsw=(1.-albedo)*sdown(kte+1)
602 LOGICAL :: allowed_to_read = .true.
603 real :: swrad_scat = 1
607 cssca = swrad_scat * 1.e-5