!WRF:MODEL_LAYER:PHYSICS ! MODULE module_ra_sw REAL,PRIVATE,SAVE :: CSSCA CONTAINS !------------------------------------------------------------------ SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO, & rho_phy,T3D,QV3D,QC3D,QR3D, & QI3D,QS3D,QG3D,P3D,pi3D,dz8w,GMT, & R,CP,G,JULDAY, & XTIME,DECLIN,SOLCON, & F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & RADFRQ,ICLOUD,DEGRAD,warm_rain, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & ) !------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------ INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte LOGICAL, INTENT(IN ) :: warm_rain INTEGER, INTENT(IN ) :: icloud REAL, INTENT(IN ) :: RADFRQ,DEGRAD, & XTIME,DECLIN,SOLCON ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: P3D, & pi3D, & rho_phy, & dz8w, & T3D REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & INTENT(IN ) :: pm2_5_dry, & pm2_5_water, & pm2_5_dry_ec REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT) :: RTHRATEN ! REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN ) :: XLAT, & XLONG, & ALBEDO ! REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: GSW ! REAL, INTENT(IN ) :: GMT,R,CP,G,dt ! INTEGER, INTENT(IN ) :: JULDAY ! ! Optional ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, & INTENT(IN ) :: & QV3D, & QC3D, & QR3D, & QI3D, & QS3D, & QG3D LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG ! LOCAL VARS REAL, DIMENSION( kts:kte ) :: & TTEN1D, & RHO01D, & P1D, & DZ, & T1D, & QV1D, & QC1D, & QR1D, & QI1D, & QS1D, & QG1D ! REAL:: XLAT0,XLONG0,ALB0,GSW0 ! INTEGER :: i,j,K,NK LOGICAL :: predicate , do_topo_shading real :: aer_dry1(kts:kte),aer_water1(kts:kte) !------------------------------------------------------------------ j_loop: DO J=jts,jte i_loop: DO I=its,ite ! reverse vars DO K=kts,kte QV1D(K)=0. QC1D(K)=0. QR1D(K)=0. QI1D(K)=0. QS1D(K)=0. QG1D(K)=0. ENDDO DO K=kts,kte NK=kme-1-K+kms TTEN1D(K)=0. T1D(K)=T3D(I,NK,J) P1D(K)=P3D(I,NK,J) RHO01D(K)=rho_phy(I,NK,J) DZ(K)=dz8w(I,NK,J) ENDDO IF( PRESENT(pm2_5_dry) .AND. PRESENT(pm2_5_water) )THEN DO K=kts,kte NK=kme-1-K+kms aer_dry1(k) = pm2_5_dry(i,nk,j) aer_water1(k) = pm2_5_water(i,nk,j) ENDDO ELSE DO K=kts,kte aer_dry1(k) = 0. aer_water1(k) = 0. ENDDO ENDIF IF (PRESENT(F_QV) .AND. PRESENT(QV3D)) THEN IF (F_QV) THEN DO K=kts,kte NK=kme-1-K+kms QV1D(K)=QV3D(I,NK,J) QV1D(K)=max(0.,QV1D(K)) ENDDO ENDIF ENDIF IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN IF (F_QC) THEN DO K=kts,kte NK=kme-1-K+kms QC1D(K)=QC3D(I,NK,J) QC1D(K)=max(0.,QC1D(K)) ENDDO ENDIF ENDIF IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN IF (F_QR) THEN DO K=kts,kte NK=kme-1-K+kms QR1D(K)=QR3D(I,NK,J) QR1D(K)=max(0.,QR1D(K)) ENDDO ENDIF ENDIF ! IF ( PRESENT( F_QI ) ) THEN predicate = F_QI ELSE predicate = .FALSE. ENDIF IF ( predicate .AND. PRESENT( QI3D ) ) THEN DO K=kts,kte NK=kme-1-K+kms QI1D(K)=QI3D(I,NK,J) QI1D(K)=max(0.,QI1D(K)) ENDDO ELSE IF (.not. warm_rain) THEN DO K=kts,kte IF(T1D(K) .lt. 273.15) THEN QI1D(K)=QC1D(K) QC1D(K)=0. QS1D(K)=QR1D(K) QR1D(K)=0. ENDIF ENDDO ENDIF ENDIF IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN IF (F_QS) THEN DO K=kts,kte NK=kme-1-K+kms QS1D(K)=QS3D(I,NK,J) QS1D(K)=max(0.,QS1D(K)) ENDDO ENDIF ENDIF IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN IF (F_QG) THEN DO K=kts,kte NK=kme-1-K+kms QG1D(K)=QG3D(I,NK,J) QG1D(K)=max(0.,QG1D(K)) ENDDO ENDIF ENDIF XLAT0=XLAT(I,J) XLONG0=XLONG(I,J) ALB0=ALBEDO(I,J) ! slope code removed - factor now done in surface driver CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, & T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, & XTIME,GMT,RHO01D,DZ, & R,CP,G,DECLIN,SOLCON, & RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & kts,kte ) GSW(I,J)=GSW0 DO K=kts,kte NK=kme-1-K+kms RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN1D(NK)/pi3D(I,K,J) ENDDO ! ENDDO i_loop ENDDO j_loop END SUBROUTINE SWRAD !------------------------------------------------------------------ SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO, & T,QV,QC,QR,QI,QS,QG,P, & XTIME, GMT, RHO0, DZ, & R,CP,G,DECLIN,SOLCON, & RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & kts,kte,slope_rad,shadow,slp_azi,slope ) !------------------------------------------------------------------ ! TO CALCULATE SHORT-WAVE ABSORPTION AND SCATTERING IN CLEAR ! AIR AND REFLECTION AND ABSORPTION IN CLOUD LAYERS (STEPHENS, ! 1984) ! CHANGES: ! REDUCE EFFECTS OF ICE CLOUDS AND PRECIP ON LIQUID WATER PATH ! ADD EFFECT OF GRAUPEL !------------------------------------------------------------------ IMPLICIT NONE INTEGER, INTENT(IN ) :: kts,kte ! REAL, DIMENSION( kts:kte ), INTENT(IN ) :: & RHO0, & T, & P, & DZ, & QV, & QC, & QR, & QI, & QS, & QG REAL, DIMENSION( kts:kte ), INTENT(INOUT):: TTEN ! REAL, INTENT(IN ) :: XTIME,GMT,R,CP,G,DECLIN, & SOLCON,XLAT,XLONG,ALBEDO, & RADFRQ, DEGRAD ! INTEGER, INTENT(IN) :: icloud REAL, INTENT(INOUT) :: GSW ! For slope-dependent radiation INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,shadow REAL, OPTIONAL, INTENT(IN) :: slp_azi,slope ! LOCAL VARS ! REAL, DIMENSION( kts:kte+1 ) :: SDOWN REAL, DIMENSION( kts:kte ) :: XLWP, & XATP, & XWVP, & aer_dry1,aer_water1, & RO ! REAL, DIMENSION( 4, 5 ) :: ALBTAB, & ABSTAB REAL, DIMENSION( 4 ) :: XMUVAL REAL :: beta !------------------------------------------------------------------ DATA ALBTAB/0.,0.,0.,0., & 69.,58.,40.,15., & 90.,80.,70.,60., & 94.,90.,82.,78., & 96.,92.,85.,80./ DATA ABSTAB/0.,0.,0.,0., & 0.,2.5,4.,5., & 0.,2.6,7.,10., & 0.,3.3,10.,14., & 0.,3.7,10.,15./ DATA XMUVAL/0.,0.2,0.5,1.0/ REAL :: bext340, absc, alba, alw, csza,dabsa,dsca,dabs REAL :: bexth2o, dscld, hrang,ff,oldalb,oldabs,oldabc REAL :: soltop, totabs, tloctm, ugcm, uv,xabs,xabsa,wv REAL :: wgm, xalb, xi, xsca, xt24,xmu,xabsc,trans0,yj REAL :: xxlat,ww INTEGER :: iil,ii,jjl,ju,k,iu ! For slope-dependent radiation REAL :: diffuse_frac, corr_fac, csza_slp GSW=0.0 bext340=5.E-6 bexth2o=5.E-6 SOLTOP=SOLCON XT24=MOD(XTIME+RADFRQ*0.5,1440.) TLOCTM=GMT+XT24/60.+XLONG/15. HRANG=15.*(TLOCTM-12.)*DEGRAD XXLAT=XLAT*DEGRAD CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG) ! RETURN IF NIGHT IF(CSZA.LE.1.E-9)GOTO 7 ! DO K=kts, kte ! P in the unit of 10mb RO(K)=P(K)/(R*T(K)) XWVP(K)=RO(K)*QV(K)*DZ(K)*1000. ! KG/M**2 XATP(K)=RO(K)*DZ(K) ENDDO ! ! G/M**2 ! REDUCE WEIGHT OF LIQUID AND ICE IN SHORT-WAVE SCHEME ! ADD GRAUPEL EFFECT (ASSUMED SAME AS RAIN) ! IF (ICLOUD.EQ.0)THEN DO K=kts, kte XLWP(K)=0. ENDDO ELSE DO K=kts, kte XLWP(K)=RO(K)*1000.*DZ(K)*(QC(K)+0.1*QI(K)+0.05* & QR(K)+0.02*QS(K)+0.05*QG(K)) ENDDO ENDIF ! XMU=CSZA SDOWN(1)=SOLTOP*XMU ! SET WW (G/M**2) LIQUID WATER PATH INTEGRATED DOWN ! SET UV (G/M**2) WATER VAPOR PATH INTEGRATED DOWN WW=0. UV=0. OLDALB=0. OLDABC=0. TOTABS=0. ! CONTRIBUTIONS DUE TO CLEAR AIR AND CLOUD DSCA=0. DABS=0. DSCLD=0. ! ! CONTRIBUTION DUE TO AEROSOLS (FOR CHEMISTRY) DABSA=0. ! DO 200 K=kts,kte WW=WW+XLWP(K) UV=UV+XWVP(K) ! WGM IS WW/COS(THETA) (G/M**2) ! UGCM IS UV/COS(THETA) (G/CM**2) WGM=WW/XMU UGCM=UV*0.0001/XMU ! OLDABS=TOTABS ! WATER VAPOR ABSORPTION AS IN LACIS AND HANSEN (1974) TOTABS=2.9*UGCM/((1.+141.5*UGCM)**0.635+5.925*UGCM) ! APPROXIMATE RAYLEIGH + AEROSOL SCATTERING ! XSCA=1.E-5*XATP(K)/XMU ! XSCA=(1.E-5*XATP(K)+aer_dry1(K)*bext340+aer_water1(K)*bexth2o)/XMU beta=0.4*(1.0-XMU)+0.1 ! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT XSCA=(cssca*XATP(K)+beta*aer_dry1(K)*bext340*DZ(K) & +beta*aer_water1(K)*bexth2o*DZ(K))/XMU ! LAYER VAPOR ABSORPTION DONE FIRST XABS=(TOTABS-OLDABS)*(SDOWN(1)-DSCLD-DSCA-DABSA)/SDOWN(K) !rs AEROSOL ABSORB (would be elemental carbon). So far XABSA = 0. XABSA=0. IF(XABS.LT.0.)XABS=0. ! ALW=ALOG10(WGM+1.) IF(ALW.GT.3.999)ALW=3.999 ! DO II=1,3 IF(XMU.GT.XMUVAL(II))THEN IIL=II IU=II+1 XI=(XMU-XMUVAL(II))/(XMUVAL(II+1)-XMUVAL(II))+FLOAT(IIL) ENDIF ENDDO ! JJL=IFIX(ALW)+1 JU=JJL+1 YJ=ALW+1. ! CLOUD ALBEDO ALBA=(ALBTAB(IU,JU)*(XI-IIL)*(YJ-JJL) & +ALBTAB(IIL,JU)*(IU-XI)*(YJ-JJL) & +ALBTAB(IU,JJL)*(XI-IIL)*(JU-YJ) & +ALBTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) & /((IU-IIL)*(JU-JJL)) ! CLOUD ABSORPTION ABSC=(ABSTAB(IU,JU)*(XI-IIL)*(YJ-JJL) & +ABSTAB(IIL,JU)*(IU-XI)*(YJ-JJL) & +ABSTAB(IU,JJL)*(XI-IIL)*(JU-YJ) & +ABSTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) & /((IU-IIL)*(JU-JJL)) ! LAYER ALBEDO AND ABSORPTION XALB=(ALBA-OLDALB)*(SDOWN(1)-DSCA-DABS)/SDOWN(K) XABSC=(ABSC-OLDABC)*(SDOWN(1)-DSCA-DABS)/SDOWN(K) IF(XALB.LT.0.)XALB=0. IF(XABSC.LT.0.)XABSC=0. DSCLD=DSCLD+(XALB+XABSC)*SDOWN(K)*0.01 DSCA=DSCA+XSCA*SDOWN(K) DABS=DABS+XABS*SDOWN(K) DABSA=DABSA+XABSA*SDOWN(K) OLDALB=ALBA OLDABC=ABSC ! LAYER TRANSMISSIVITY TRANS0=100.-XALB-XABSC-XABS*100.-XSCA*100. IF(TRANS0.LT.1.)THEN FF=99./(XALB+XABSC+XABS*100.+XSCA*100.) XALB=XALB*FF XABSC=XABSC*FF XABS=XABS*FF XSCA=XSCA*FF TRANS0=1. ENDIF SDOWN(K+1)=AMAX1(1.E-9,SDOWN(K)*TRANS0*0.01) TTEN(K)=SDOWN(K)*(XABSC+XABS*100.+XABSA*100.)*0.01/( & RO(K)*CP*DZ(K)) 200 CONTINUE ! GSW=(1.-ALBEDO)*SDOWN(kte+1) IF (PRESENT(slope_rad)) THEN ! Slope-dependent solar radiation part if (slope_rad.eq.1) then ! Parameterize diffuse fraction of global solar radiation as a function of the ratio between TOA radiation and surface global radiation diffuse_frac = min(1.,1/(max(0.1,2.1-2.8*log(log(SDOWN(kts)/max(SDOWN(kte+1),1.e-3)))))) 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 corr_fac = 1 goto 140 endif ! cosine of zenith angle over sloping topography csza_slp = ((SIN(XXLAT)*COS(HRANG))* & (-cos(slp_azi)*sin(slope))-SIN(HRANG)*(sin(slp_azi)*sin(slope))+ & (COS(XXLAT)*COS(HRANG))*cos(slope))* & COS(DECLIN)+(COS(XXLAT)*(cos(slp_azi)*sin(slope))+ & SIN(XXLAT)*cos(slope))*SIN(DECLIN) IF(csza_slp.LE.1.E-4) csza_slp = 0 ! Topographic shading if (shadow.eq.1) csza_slp = 0 ! Correction factor for sloping topography; the diffuse fraction of solar radiation is assumed to be unaffected by the slope corr_fac = diffuse_frac + (1-diffuse_frac)*csza_slp/csza 140 continue GSW=(1.-ALBEDO)*SDOWN(kte+1)*corr_fac endif ENDIF 7 CONTINUE ! END SUBROUTINE SWPARA !==================================================================== SUBROUTINE swinit(swrad_scat, & allowed_to_read , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !-------------------------------------------------------------------- IMPLICIT NONE !-------------------------------------------------------------------- LOGICAL , INTENT(IN) :: allowed_to_read INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , INTENT(IN) :: swrad_scat ! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT cssca = swrad_scat * 1.e-5 END SUBROUTINE swinit END MODULE module_ra_sw