MODULE module_ra_hs CONTAINS SUBROUTINE HSRAD(RTHRATEN,GLW,GSW,p8w,p_phy,pi_phy,dz8w,t_phy, & t8w, rho_phy, R_d,G,CP,dt,xlat,degrad, & QV, tsk, & 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 REAL, INTENT(IN ) :: DEGRAD REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT) :: RTHRATEN REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: GSW, & GLW REAL, INTENT(IN ) :: R_d,CP,G,dt REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: dz8w, & p8w, & p_phy, & pi_phy, & t_phy, & t8w, & rho_phy REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN ) :: xlat LOGICAL :: drycase INTEGER :: i,j,K,kte_,K_ REAL :: dely,rcp,g0, r_terre REAL :: sigma, nk LOGICAL :: is_tau_front, is_tau_invert INTEGER :: create_sst REAL :: tau0pole,tau0eq,radflin,radfnlin REAL :: ytau, ltau, ysst, lsst, ssteq, sstpole LOGICAL :: use_tsk_tau, use_tsk_rad_bc REAL :: deltath_z REAL :: tau0, arg_phi, sst, tsfc REAL :: s8w REAL :: Dsw,Dp,Q_tend REAL :: n_tau,dtau REAL :: tau_strato,tau_tropo REAL, DIMENSION( kms:kme) :: F_up, F_down, B, tau REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT) :: QV REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN) :: tsk CALL nl_get_asiv_ssteq(1,ssteq) CALL nl_get_asiv_tau0eq(1,tau0eq) CALL nl_get_asiv_sstpole(1,sstpole) CALL nl_get_asiv_tau0pole(1,tau0pole) CALL nl_get_asiv_is_tau_front(1, is_tau_front) CALL nl_get_asiv_create_sst(1, create_sst) CALL nl_get_asiv_is_tau_invert(1, is_tau_invert) CALL nl_get_asiv_use_tsk_tau(1, use_tsk_tau) CALL nl_get_asiv_use_tsk_rad_bc(1, use_tsk_rad_bc) CALL nl_get_asiv_ltau(1,ltau) CALL nl_get_asiv_ytau(1,ytau) CALL nl_get_asiv_lsst(1,lsst) CALL nl_get_asiv_ysst(1,ysst) CALL nl_get_asiv_drycase(1,drycase) CALL nl_get_asiv_radflin(1,radflin) CALL nl_get_dy(1,dely) CALL nl_get_asiv_deltath_z(1,deltath_z) rcp = R_d/CP g0 = 9.8 n_tau = 4. sigma = 5.6734E-8 kte_ = MIN(kte,kde-1) nk = 4. * rcp radfnlin = 1. - radflin j_loop: DO J=jts,MIN(jte,jde-1) i_loop: DO I=its,MIN(ite,ide-1) LOOP_Q: DO K=kts,kte_ IF ( drycase ) THEN QV(I,K,J) = 0. END IF ENDDO LOOP_Q IF ( is_tau_front ) THEN arg_phi = (j*dely/1000.0-ytau)/ltau tau0 = tau0eq - 0.5 * (tau0eq-tau0pole) * (1+tanh(arg_phi)) ELSE arg_phi = (J*dely/1000.0-ytau)/4.0e3 if(arg_phi>1.)arg_phi=1. if(arg_phi<-1.)arg_phi=-1. tau0=(tau0eq+tau0pole)/2.-(tau0eq-tau0pole)* & sin(3.14159265*arg_phi/2.)/2. END IF IF ( use_tsk_tau ) THEN tsfc = (((1.0+tau0)/(2.0+tau0))**0.25) * tsk(I,J) ELSE sst=293. arg_phi = (dely*float(J)/1000.0-ysst)/lsst IF ( create_sst.eq.0) THEN sst = 0.5*(ssteq+sstpole) ELSEIF(create_sst.eq.1)THEN arg_phi = (J*dely/1000.0-ysst)/4.0e3 if(arg_phi>1.)arg_phi=1. if(arg_phi<-1.)arg_phi=-1. sst=(ssteq+sstpole)/2.-(ssteq-sstpole)* & sin(3.14159265*arg_phi/2.)/2. ELSEIF(create_sst.eq.2)THEN sst= ssteq - 0.5*(ssteq - sstpole)*(1+tanh(arg_phi)) END IF tsfc = (((1.0+tau0)/(2.0+tau0))**0.25) * sst END IF LOOP_TAU: DO K=kts,kte_ s8w=p8w(i,K,j)/p8w(i,1,j) IF ( is_tau_invert ) THEN tau_tropo = (1.0+tau0) * (s8w**nk) * ((1.0 - deltath_z*alog(s8w)/tsfc)**4) - 1.0 tau_strato = tau0 * radflin * s8w tau(K) = max(tau_strato, tau_tropo) ELSE tau(K) = tau0*(radflin*s8w + radfnlin*(s8w**n_tau)) END IF B(K) = sigma*(t_phy(i,k,j)**4.0) ENDDO LOOP_TAU IF ( use_tsk_rad_bc ) THEN F_up(kts) = sigma*(tsk(I,J)**4.0) ELSE F_up(kts) = sigma*(sst**4.0) END IF F_down(kte_) = 0. LOOP_FLUXES: DO K=kts,kte_-1 dtau = tau(K+1)-tau(K) F_up(K+1) = F_up(K) * (1.0 + 0.5*dtau) - B(K) * dtau F_up(K+1) = F_up(K+1) / (1.0 - 0.5*dtau) K_ = kte_ + kts - K dtau = tau(K_-1)-tau(K_) F_down(K_-1) = F_down(K_) * (1.0 - 0.5*dtau) + B(K_-1) * dtau F_down(K_-1) = F_down(K_-1) / (1.0 + 0.5*dtau) ENDDO LOOP_FLUXES GLW(I,J)=F_down(kts) GSW(I,J)=0. LOOP_RTHRATEN: DO K=kts,kte_-1 Dsw = F_up(K+1)-F_up(K)+F_down(K)-F_down(K+1) Dp = p8w(i,K+1,j)-p8w(i,K,j) Q_tend = g0/CP* Dsw/Dp RTHRATEN(I,K,J)=RTHRATEN(I,K,J) + & Q_tend / pi_phy(i,K,j) ENDDO LOOP_RTHRATEN ENDDO i_loop ENDDO j_loop END SUBROUTINE HSRAD SUBROUTINE hsinit(RTHRATEN,restart, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) IMPLICIT NONE LOGICAL , INTENT(IN) :: restart INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: & RTHRATEN INTEGER :: i, j, k, itf, jtf, ktf jtf=min0(jte,jde-1) ktf=min0(kte,kde-1) itf=min0(ite,ide-1) IF(.not.restart)THEN DO j=jts,jtf DO k=kts,ktf DO i=its,itf RTHRATEN(i,k,j)=0. ENDDO ENDDO ENDDO ENDIF END SUBROUTINE hsinit END MODULE module_ra_hs