From c207cc8e60c152d2efa72a5f5139723a39d9b0be Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Thu, 5 Dec 2019 18:43:11 +0000 Subject: [PATCH 01/16] Adding moninedmf_hafs.f. Making the GFS EDMF HWRF code CCPP complaiant. --- physics/moninedmf_hafs.f | 1459 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 1459 insertions(+) create mode 100644 physics/moninedmf_hafs.f diff --git a/physics/moninedmf_hafs.f b/physics/moninedmf_hafs.f new file mode 100644 index 000000000..d2817c654 --- /dev/null +++ b/physics/moninedmf_hafs.f @@ -0,0 +1,1459 @@ +!> \file moninedmf.f +!! Contains most of the hybrid eddy-diffusivity mass-flux scheme except for the +!! subroutine that calculates the mass flux and updraft properties. + +!> This module contains the CCPP-compliant hybrid eddy-diffusivity mass-flux +!! scheme for HAFS applications. + +!> \defgroup HEDMF Hybrid Eddy-diffusivity Mass-flux Scheme +!! @{ +!! \brief The Hybrid EDMF scheme is a first-order turbulent transport scheme used for subgrid-scale vertical turbulent mixing in the PBL and above. It blends the traditional first-order approach that has been used and improved over the last several years with a more recent scheme that uses a mass-flux approach to calculate the countergradient diffusion terms. +!! +!! The PBL scheme's main task is to calculate tendencies of temperature, moisture, and momentum due to vertical diffusion throughout the column (not just the PBL). The scheme is an amalg amation of decades of work, starting from the initial first-order PBL scheme of Troen and Mahrt (1986) \cite troen_and_mahrt_1986, implemented according to Hong and Pan (1996) \cite hong_ and_pan_1996 and modified by Han and Pan (2011) \cite han_and_pan_2011 and Han et al. (2015) \cite han_et_al_2015 to include top-down mixing due to stratocumulus layers from Lock et al. ( 2000) \cite lock_et_al_2000 and replacement of counter-gradient terms with a mass flux scheme according to Siebesma et al. (2007) \cite siebesma_et_al_2007 and Soares et al. (2004) \cite soares_et_al_2004. Recently, heating due to TKE dissipation was also added according to Han et al. (2015) \cite han_et_al_2015. +!! +!! \section diagram Calling Hierarchy Diagram +!! \image html Hybrid_EDMF_Flowchart.png "Diagram depicting how the Hybrid EDMF PBL scheme is called from the GSM physics time loop" height=2cm +!! \section intraphysics Intraphysics Communication +!! This space is reserved for a description of how this scheme uses information from other scheme types and/or how information calculated in this scheme is used in other scheme types. +!> \brief This subroutine contains all of logic for the Hybrid EDMF PBL scheme except for the calculation of the updraft properties and mass flux. +!! +!! The scheme works on a basic level by calculating background diffusion coefficients and updating them according to which processes are occurring in the column. The most important difference in diffusion coefficients occurs between those levels in the PBL and those above the PBL, so the PBL height calculation is of utmost importance. An initial estimate is calculated in a "predictor" step in order to calculate Monin-Obukhov similarity values an d a corrector step recalculates the PBL height based on updated surface thermal characteristics. Using the PBL height and the similarity parameters, the diffusion coefficients are updated below the PBL top based on Hong and Pan (1996) \cite hong_and_pan_1996 (including counter-gradient terms). Diffusion coefficients in the free troposphere (above the PBL top) are calculated according to Louis (1979) \cite louis_1979 with updated Richardson number -dependent functions. If it is diagnosed that PBL top-down mixing is occurring according to Lock et al. (2000) \cite lock_et_al_2000 , then then diffu sion coefficients are updated accordingly. Finally, for convective boundary layers (defined as when the Obukhov length exceeds a threshold), the count er-gradient terms are replaced using the mass flux scheme of Siebesma et al. (2007) \cite siebesma_et_al_2007 . In order to return time tendencies, a fully implicit solution is found using tridiagonal matrices, and time tendencies are "backed out." Before returning, the time tendency of temperature is updated to reflect heating due to TKE dissipation following Han et al. (2015) \cite han_et_al_2015 . +!! +!! WeiGuo Wang updated the scheme for HAFS in July, 2019. + + module hedmf + + contains + +!> \section arg_table_hedmf_init Argument Table +!! \htmlinclude hedmf_init.html +!! + subroutine hedmf_init (moninq_fac,errmsg,errflg) + use machine, only : kind_phys + implicit none + real(kind=kind_phys), intent(in ) :: moninq_fac + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (moninq_fac == 0) then + errflg = 1 + write(errmsg,'(*(a))') 'Logic error: moninq_fac == 0', + & ' is incompatible with hedmf' + end if + end subroutine hedmf_init + + subroutine hedmf_finalize () + end subroutine hedmf_finalize + + +!> \defgroup HEDMF GFS Hybrid Eddy-Diffusivity Mass-Flux (HEDMF) Scheme Module +!! @{ +!! \brief This subroutine contains all of logic for the +!! Hybrid EDMF PBL scheme except for the calculation of +!! the updraft properties and mass flux. +!! +!> \section arg_table_hedmf_run Argument Table +!! \htmlinclude hedmf_run.html +!! +!! \section general_edmf GFS Hybrid EDMF General Algorithm +!! -# Compute preliminary variables from input arguments. +!! -# Calculate the first estimate of the PBL height ("Predictor step"). +!! -# Calculate Monin-Obukhov similarity parameters. +!! -# Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). +!! -# Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion. +!! -# Calculate the inverse Prandtl number. +!! -# Compute diffusion coefficients below the PBL top. +!! -# Compute diffusion coefficients above the PBL top. +!! -# If the PBL is convective, call the mass flux scheme to replace the countergradient terms. +!! -# Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs. +!! -# Solve for the temperature and moisture tendencies due to vertical mixing. +!! -# Calculate heating due to TKE dissipation and add to the tendency for temperature. +!! -# Solve for the horizontal momentum tendencies and add them to output tendency terms. +!! \section detailed_hedmf GFS Hybrid HEDMF Detailed Algorithm +!! @{ + subroutine hedmf_hafs_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & + & u1,v1,t1,q1,swh,hlw,xmu, & + & psk,rbsoil,zorl,u10m,v10m,fm,fh, & + & tsea,heat,evap,stress,spd1,kpbl, & + & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & + & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & + & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & + & xkzminv,moninq_fac,islimsk,errmsg,errflg) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, rd => con_rd, cp => con_cp + &, hvap => con_hvap, fv => con_fvirt + implicit none +! +! arguments +! + logical, intent(in) :: lprnt + integer, intent(in) :: ipr + integer, intent(in) :: ix, im, km, ntrac, ntcw, kinver(im) + integer, intent(out) :: kpbl(im) + +! + real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac + real(kind=kind_phys), intent(inout) :: dv(im,km), du(im,km), & + & tau(im,km), rtg(im,km,ntrac) + real(kind=kind_phys), intent(in) :: & + & u1(ix,km), v1(ix,km), & + & t1(ix,km), q1(ix,km,ntrac), & + & swh(ix,km), hlw(ix,km), & + & xmu(im), psk(im), & + & rbsoil(im), zorl(im), & + & u10m(im), v10m(im), & + & fm(im), fh(im), & + & tsea(im), & + & heat(im), evap(im), & + & stress(im), spd1(im) + real(kind=kind_phys), intent(in) :: & + & prsi(ix,km+1), del(ix,km), & + & prsl(ix,km), prslk(ix,km), & + & phii(ix,km+1), phil(ix,km) + real(kind=kind_phys), intent(out) :: & + & dusfc(im), dvsfc(im), & + & dtsfc(im), dqsfc(im), & + & hpbl(im), dkt(im,km-1) + real(kind=kind_phys), intent(inout) :: & + & hgamt(im), hgamq(im) +! + logical, intent(in) :: dspheat +! flag for tke dissipative heating + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! +! locals + + integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond + integer lcld(im),icld(im),kcld(im),krad(im) + integer kx1(im), kpblx(im) + + integer islimsk(1:im) +! +! real(kind=kind_phys) betaq(im), betat(im), betaw(im), + real(kind=kind_phys) phih(im), phim(im), hpblx(im), & + & rbdn(im), rbup(im), & + & beta(im), sflux(im), & + & z0(im), crb(im), wstar(im), & + & zol(im), ustmin(im), ustar(im), & + & thermal(im),wscale(im), wscaleu(im) +! + real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), & + & qlx(im,km), thetae(im,km), & + & qtx(im,km), bf(im,km-1), diss(im,km), & + & radx(im,km-1), & + & govrth(im), hrad(im), & +! & hradm(im), radmin(im), vrad(im), & + & radmin(im), vrad(im), & + & zd(im), zdd(im), thlvx1(im) +! + real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1), & + & zi(im,km+1), zl(im,km), xkzo(im,km-1), & + & dku(im,km-1), xkzmo(im,km-1), & + & cku(im,km-1), ckt(im,km-1), & + & ti(im,km-1), shr2(im,km-1), & + & al(im,km-1), ad(im,km), & + & au(im,km-1), a1(im,km), & + & a2(im,km*ntrac) +! + real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), & + & ucko(im,km), vcko(im,km), xmf(im,km) +! + real(kind=kind_phys) prinv(im), rent(im) +! + logical pblflg(im), sfcflg(im), scuflg(im), flg(im) + logical ublflg(im), pcnvflg(im) +! +! pcnvflg: true for convective(strongly unstable) pbl +! ublflg: true for unstable but not convective(strongly unstable) pbl +! + real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, + & cfac, conq, cont, conw, + & dk, dkmax, dkmin, + & dq1, dsdz2, dsdzq, dsdzt, + & dsdzu, dsdzv, + & dsig, dt2, dthe1, dtodsd, + & dtodsu, dw2, dw2min, g, + & gamcrq, gamcrt, gocp, + & gravi, f0, + & prnum, prmax, prmin, pfac, crbcon, + & qmin, tdzmin, qtend, crbmin,crbmax, + & rbint, rdt, rdz, qlmin, + & ri, rimin, rl2, rlam, rlamun, + & rone, rzero, sfcfrac, + & spdk2, sri, zol1, zolcr, zolcru, + & robn, ttend, + & utend, vk, vk2, + & ust3, wst3, + & vtend, zfac, vpert, cteit, + & rentf1, rentf2, radfac, + & zfmin, zk, tem, tem1, tem2, + & xkzm, xkzmu, + & ptem, ptem1, ptem2, tx1(im), tx2(im) +! + real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, + & cldtime + +!! for alpha (HAFS) + real(kind=kind_phys) WSPM(IM,KM-1) + integer kLOC ! RGF + real :: xDKU, ALPHA ! RGF + + integer :: useshape + real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax + +cc + parameter(gravi=1.0/grav) + parameter(g=grav) + parameter(gocp=g/cp) + parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa +! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) ! for del in kpa + parameter(rlam=30.0,vk=0.4,vk2=vk*vk) + parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5) + parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) + parameter(crbcon=0.25,crbmin=0.15,crbmax=0.35) + parameter(wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) +! parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(qmin=1.e-8, zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(tdzmin=1.e-3,qlmin=1.e-12,f0=1.e-4) + parameter(h1=0.33333333,h2=0.66666667) +! parameter(cldtime=500.,xkzminv=0.3) + parameter(cldtime=500.) +! parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3) +! parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0) + parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0) + parameter(rentf1=0.2,rentf2=1.0,radfac=0.85) + parameter(iun=84) +! +! parameter (zstblmax = 2500., qlcr=1.0e-5) +! parameter (zstblmax = 2500., qlcr=3.0e-5) +! parameter (zstblmax = 2500., qlcr=3.5e-5) +! parameter (zstblmax = 2500., qlcr=1.0e-4) + parameter (zstblmax = 2500., qlcr=3.5e-5) +! parameter (actei = 0.23) + parameter (actei = 0.7) + +! HAFS PBL: height-dependent ALPHA + useshape=2 !0-- no change, origincal ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) + alpha=moninq_fac + + write(0,*)'in PBL,alpha=',alpha + + write(0,*)'islimsk=',(islimsk(i),i=1,im) +c +c----------------------------------------------------------------------- +c + 601 format(1x,' moninp lat lon step hour ',3i6,f6.1) + 602 format(1x,' k',' z',' t',' th', + 1 ' tvh',' q',' u',' v', + 2 ' sp') + 603 format(1x,i5,8f9.1) + 604 format(1x,' sfc',9x,f9.1,18x,f9.1) + 605 format(1x,' k zl spd2 thekv the1v' + 1 ,' thermal rbup') + 606 format(1x,i5,6f8.2) + 607 format(1x,' kpbl hpbl fm fh hgamt', + 1 ' hgamq ws ustar cd ch') + 608 format(1x,i5,9f8.2) + 609 format(1x,' k pr dkt dku ',i5,3f8.2) + 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', + 1 ' sr2 ',2f8.2,2e10.2) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!> ## Compute preliminary variables from input arguments + +! compute preliminary variables +! + if (ix .lt. im) stop +! +! iprt = 0 +! if(iprt.eq.1) then +!cc latd = 0 +! lond = 0 +! else +!cc latd = 0 +! lond = 0 +! endif +! + dt2 = delt + rdt = 1. / dt2 + km1 = km - 1 + kmpbl = km / 2 +!> - Compute physical height of the layer centers and interfaces from the geopotential height (zi and zl) + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo +!> - Compute reciprocal of \f$ \Delta z \f$ (rdzt) + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + enddo + enddo +!> - Compute reciprocal of pressure (tx1, tx2) + do i=1,im + kx1(i) = 1 + tx1(i) = 1.0 / prsi(i,1) + tx2(i) = tx1(i) + enddo +!> - Compute background vertical diffusivities for scalars and momentum (xkzo and xkzmo) + do k = 1,km1 + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! vertical background diffusivity + ptem = prsi(i,k+1) * tx1(i) + tem1 = 1.0 - ptem + tem1 = tem1 * tem1 * 10.0 + xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) + +! vertical background diffusivity for momentum + if (ptem >= xkzm_s) then + xkzmo(i,k) = xkzm_m + kx1(i) = k + 1 + else + if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) + tem1 = 1.0 - prsi(i,k+1) * tx2(i) + tem1 = tem1 * tem1 * 5.0 + xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! if (lprnt) then +! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) +! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) +! endif +! +! diffusivity in the inversion layer is set to be xkzminv (m^2/s) +!> - The background scalar vertical diffusivity is limited to be less than or equal to xkzminv + do k = 1,kmpbl + do i=1,im +! if(zi(i,k+1) > 200..and.zi(i,k+1) < zstblmax) then + if(zi(i,k+1) > 250.) then + tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) + if(tem1 > 1.e-5) then + xkzo(i,k) = min(xkzo(i,k),xkzminv) + endif + endif + enddo + enddo +!> - Some output variables and logical flags are initialized + do i = 1,im + z0(i) = 0.01 * zorl(i) + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + wscale(i)= 0. + wscaleu(i)= 0. + kpbl(i) = 1 + hpbl(i) = zi(i,1) + hpblx(i) = zi(i,1) + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + ublflg(i)= .false. + pcnvflg(i)= .false. + scuflg(i)= .true. + if(scuflg(i)) then + radmin(i)= 0. + rent(i) = rentf1 + hrad(i) = zi(i,1) +! hradm(i) = zi(i,1) + krad(i) = 1 + icld(i) = 0 + lcld(i) = km1 + kcld(i) = km1 + zd(i) = 0. + endif + enddo +!> - Compute \f$\theta\f$ (theta), \f$q_l\f$ (qlx), \f$q_t\f$ (qtx), \f$\theta_e\f$ (thetae), \f$\theta_v\f$ (thvx), \f$\theta_{l,v}\f$ (thlvx) + do k = 1,km + do i = 1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + qlx(i,k) = max(q1(i,k,ntcw),qlmin) + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + ptem = qlx(i,k) + ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k)) + thetae(i,k)= theta(i,k)*(1.+ptem1) + thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem) + ptem2 = theta(i,k)-(hvap/cp)*ptem + thlvx(i,k) = ptem2*(1.+fv*qtx(i,k)) + enddo + enddo +!> - Initialize diffusion coefficients to 0 and calculate the total radiative heating rate (dku, dkt, radx) + do k = 1,km1 + do i = 1,im + dku(i,k) = 0. + dkt(i,k) = 0. + dktx(i,k) = 0. + cku(i,k) = 0. + ckt(i,k) = 0. + tem = zi(i,k+1)-zi(i,k) + radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) + enddo + enddo +!> - Set lcld to first index above 2.5km + do i=1,im + flg(i) = scuflg(i) + enddo + do k = 1, km1 + do i=1,im + if(flg(i).and.zl(i,k) >= zstblmax) then + lcld(i)=k + flg(i)=.false. + endif + enddo + enddo +! +! compute virtual potential temp gradient (bf) and winshear square +!> - Compute \f$\frac{\partial \theta_v}{\partial z}\f$ (bf) and the wind shear squared (shr2) + do k = 1, km1 + do i = 1, im + rdz = rdzt(i,k) + bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdz + ti(i,k) = 2./(t1(i,k)+t1(i,k+1)) + dw2 = (u1(i,k)-u1(i,k+1))**2 + & + (v1(i,k)-v1(i,k+1))**2 + shr2(i,k) = max(dw2,dw2min)*rdz*rdz + enddo + enddo +!> - Calculate \f$\frac{g}{\theta}\f$ (govrth), \f$\beta = \frac{\Delta t}{\Delta z}\f$ (beta), \f$u_*\f$ (ustar), total surface flux (sflux), and set pblflag to false if the total surface energy flux is into the surface + do i = 1,im + govrth(i) = g/theta(i,1) + enddo +! + do i=1,im + beta(i) = dt2 / (zi(i,2)-zi(i,1)) + enddo +! + do i=1,im + ustar(i) = sqrt(stress(i)) + enddo +! + do i = 1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + enddo +!> ## Calculate the first estimate of the PBL height ("Predictor step") +!! The calculation of the boundary layer height follows Troen and Mahrt (1986) \cite troen_and_mahrt_1986 section 3. The approach is to find the level in the column where a modified bulk Richardson number exceeds a critical value. +!! +!! The temperature of the thermal is of primary importance. For the initial estimate of the PBL height, the thermal is assumed to have one of two temperatures. If the boundary layer is stable, the thermal is assumed to have a temperature equal to the surface virtual temperature. Otherwise, the thermal is assumed to have the same virtual potential temperature as the lowest model level. For the stable case, the critical bulk Richardson number becomes a function of the wind speed and roughness length, otherwise it is set to a tunable constant. +! compute the pbl height +! + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) +! + IF ( ALPHA .GT. 0.0) THEN ! ALPHA + + if(pblflg(i)) then + thermal(i) = thvx(i,1) + crb(i) = crbcon + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = max(min(crb(i), crbmax), crbmin) + endif + + ELSE +! use variable Ri for all conditions + if(pblflg(i)) then + thermal(i) = thvx(i,1) + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + endif + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn +! crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = crbcon + IF(islimsk(i).ne.0) crb(I) = 0.16*(tem1)**(-0.18) + IF(islimsk(i).eq.0) crb(I) = 0.25*(tem1)**(-0.18) + crb(i) = max(min(crb(i), crbmax), crbmin) + ENDIF ! ALPHA + + enddo +!> Given the thermal's properties and the critical Richardson number, a loop is executed to find the first level above the surface where the modified Richardson number is greater than the critical Richardson number, using equation 10a from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): +!! \f[ +!! h = Ri\frac{T_0\left|\vec{v}(h)\right|^2}{g\left(\theta_v(h) - \theta_s\right)} +!! \f] +!! where \f$h\f$ is the PBL height, \f$Ri\f$ is the Richardson number, \f$T_0\f$ is the virtual potential temperature near the surface, \f$\left|\vec{v}\right|\f$ is the wind speed, and \f$\theta_s\f$ is for the thermal. Rearranging this equation to calculate the modified Richardson number at each level, k, for comparison with the critical value yields: +!! \f[ +!! Ri_k = gz(k)\frac{\left(\theta_v(k) - \theta_s\right)}{\theta_v(1)*\vec{v}(k)} +!! \f] + do k = 1, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thvx(i,k)-thermal(i))* + & (g*zl(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo +!> Once the level is found, some linear interpolation is performed to find the exact height of the boundary layer top (where \f$Ri = Ri_{cr}\f$) and the PBL height and the PBL top index are saved (hpblx and kpblx, respectively) + do i = 1,im + if(kpbl(i) > 1) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + else + hpbl(i) = zl(i,1) + kpbl(i) = 1 + endif + kpblx(i) = kpbl(i) + hpblx(i) = hpbl(i) + enddo +! +! compute similarity parameters +!> ## Calculate Monin-Obukhov similarity parameters +!! Using the initial guess for the PBL height, Monin-Obukhov similarity parameters are calculated. They are needed to refine the PBL height calculation and for calculating diffusion coefficients. +!! +!! First, calculate the Monin-Obukhov nondimensional stability parameter, commonly referred to as \f$\zeta\f$ using the following equation from Businger et al. (1971) \cite businger_et_al_1971 (equation 28): +!! \f[ +!! \zeta = Ri_{sfc}\frac{F_m^2}{F_h} = \frac{z}{L} +!! \f] +!! where \f$F_m\f$ and \f$F_h\f$ are surface Monin-Obukhov stability functions calculated in sfc_diff.f and \f$L\f$ is the Obukhov length. Then, the nondimensional gradients of momentum and temperature (phim and phih) are calculated using equations 5 and 6 from Hong and Pan (1996) \cite hong_and_pan_1996 depending on the surface layer stability. Then, the velocity scale valid for the surface layer (\f$w_s\f$, wscale) is calculated using equation 3 from Hong and Pan (1996) \cite hong_and_pan_1996. For the neutral and unstable PBL above the surface layer, the convective velocity scale, \f$w_*\f$, is calculated according to: +!! \f[ +!! w_* = \left(\frac{g}{\theta_0}h\overline{w'\theta_0'}\right)^{1/3} +!! \f] +!! and the mixed layer velocity scale is then calculated with equation 6 from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 +!! \f[ +!! w_s = (u_*^3 + 7\epsilon k w_*^3)^{1/3} +!! \f] + do i=1,im + zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + if(sfcflg(i)) then + zol(i) = min(zol(i),-zfmin) + else + zol(i) = max(zol(i),zfmin) + endif + zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) + if(sfcflg(i)) then +! phim(i) = (1.-aphi16*zol1)**(-1./4.) +! phih(i) = (1.-aphi16*zol1)**(-1./2.) + tem = 1.0 / (1. - aphi16*zol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + else + phim(i) = 1. + aphi5*zol1 + phih(i) = phim(i) + endif + wscale(i) = ustar(i)/phim(i) + ustmin(i) = ustar(i)/aphi5 + wscale(i) = max(wscale(i),ustmin(i)) + enddo + do i=1,im + if(pblflg(i)) then + if(zol(i) < zolcru .and. kpbl(i) > 1) then + pcnvflg(i) = .true. + else + ublflg(i) = .true. + endif + wst3 = govrth(i)*sflux(i)*hpbl(i) + wstar(i)= wst3**h1 + ust3 = ustar(i)**3. + wscaleu(i) = (ust3+wfac*vk*wst3*sfcfrac)**h1 + wscaleu(i) = max(wscaleu(i),ustmin(i)) + endif + enddo +! +! compute counter-gradient mixing term for heat and moisture +!> ## Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). +!! Next, the counter-gradient terms for temperature and humidity are calculated using equation 4 of Hong and Pan (1996) \cite hong_and_pan_1996 and are used to calculate the "scaled virtual temperature excess near the surface" (equation 9 in Hong and Pan (1996) \cite hong_and_pan_1996) so that the properties of the thermal are updated to recalculate the PBL height. + do i = 1,im + if(ublflg(i)) then + hgamt(i) = min(cfac*heat(i)/wscaleu(i),gamcrt) + hgamq(i) = min(cfac*evap(i)/wscaleu(i),gamcrq) + vpert = hgamt(i) + hgamq(i)*fv*theta(i,1) + vpert = min(vpert,gamcrt) + thermal(i)= thermal(i)+max(vpert,0.) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + endif + enddo +! +! enhance the pbl height by considering the thermal excess +!> The PBL height calculation follows the same procedure as the predictor step, except that it uses an updated virtual potential temperature for the thermal. + do i=1,im + flg(i) = .true. + if(ublflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thvx(i,k)-thermal(i))* + & (g*zl(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(ublflg(i)) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + if(kpbl(i) <= 1) then + ublflg(i) = .false. + pblflg(i) = .false. + endif + endif + enddo +! +! look for stratocumulus +!> ## Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion +!! - Starting at the PBL top and going downward, if the level is less than 2.5 km and \f$q_l>q_{l,cr}\f$ then set kcld = k (find the cloud top index in the PBL). If no cloud water above the threshold is found, scuflg is set to F. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i) .and. k <= lcld(i)) then + if(qlx(i,k).ge.qlcr) then + kcld(i)=k + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. kcld(i)==km1) scuflg(i)=.false. + enddo +!> - Starting at the PBL top and going downward, if the level is less than the cloud top, find the level of the minimum radiative heating rate within the cloud. If the level of the minimum is the lowest model level or the minimum radiative heating rate is positive, then set scuflg to F. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i) .and. k <= kcld(i)) then + if(qlx(i,k) >= qlcr) then + if(radx(i,k) < radmin(i)) then + radmin(i)=radx(i,k) + krad(i)=k + endif + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. krad(i) <= 1) scuflg(i)=.false. + if(scuflg(i) .and. radmin(i)>=0.) scuflg(i)=.false. + enddo +!> - Starting at the PBL top and going downward, count the number of levels below the minimum radiative heating rate level that have cloud water above the threshold. If there are none, then set the scuflg to F. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,2,-1 + do i = 1, im + if(flg(i) .and. k <= krad(i)) then + if(qlx(i,k) >= qlcr) then + icld(i)=icld(i)+1 + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. icld(i) < 1) scuflg(i)=.false. + enddo +!> - Find the height of the interface where the minimum in radiative heating rate is located. If this height is less than the second model interface height, then set the scuflg to F. + do i = 1, im + if(scuflg(i)) then + hrad(i) = zi(i,krad(i)+1) +! hradm(i)= zl(i,krad(i)) + endif + enddo +! + do i = 1, im + if(scuflg(i) .and. hrad(i) - Calculate the hypothetical \f$\theta_v\f$ at the minimum radiative heating level that a parcel would reach due to radiative cooling after a typical cloud turnover time spent at that level. + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = zi(i,k+1)-zi(i,k) + tem1 = cldtime*radmin(i)/tem + thlvx1(i) = thlvx(i,k)+tem1 +! if(thlvx1(i) > thlvx(i,k-1)) scuflg(i)=.false. + endif + enddo +!> - Determine the distance that a parcel would sink downwards starting from the level of minimum radiative heating rate by comparing the hypothetical minimum \f$\theta_v\f$ calculated above with the environmental \f$\theta_v\f$. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i) .and. k <= krad(i))then + if(thlvx1(i) <= thlvx(i,k))then + tem=zi(i,k+1)-zi(i,k) + zd(i)=zd(i)+tem + else + flg(i)=.false. + endif + endif + enddo + enddo +!> - Calculate the cloud thickness, where the cloud top is the in-cloud minimum radiative heating level and the bottom is determined previously. + do i = 1, im + if(scuflg(i))then + kk = max(1, krad(i)+1-icld(i)) + zdd(i) = hrad(i)-zi(i,kk) + endif + enddo +!> - Find the largest between the cloud thickness and the distance of a sinking parcel, then determine the smallest of that number and the height of the minimum in radiative heating rate. Set this number to \f$zd\f$. Using \f$zd\f$, calculate the characteristic velocity scale of cloud-top radiative cooling-driven turbulence. + do i = 1, im + if(scuflg(i))then + zd(i) = max(zd(i),zdd(i)) + zd(i) = min(zd(i),hrad(i)) + tem = govrth(i)*zd(i)*(-radmin(i)) + vrad(i)= tem**h1 + endif + enddo +! +! compute inverse prandtl number +!> ## Calculate the inverse Prandtl number +!! For an unstable PBL, the Prandtl number is calculated according to Hong and Pan (1996) \cite hong_and_pan_1996, equation 10, whereas for a stable boundary layer, the Prandtl number is simply \f$Pr = \frac{\phi_h}{\phi_m}\f$. + do i = 1, im + if(ublflg(i)) then + tem = phih(i)/phim(i)+cfac*vk*sfcfrac + else + tem = phih(i)/phim(i) + endif + prinv(i) = 1.0 / tem + prinv(i) = min(prinv(i),prmax) + prinv(i) = max(prinv(i),prmin) + enddo + do i = 1, im + if(zol(i) > zolcr) then + kpbl(i) = 1 + endif + enddo + +!!! HAFS PBL, Bgin adjustment +! RGF determine wspd at roughly 500 m above surface, or as close as +! possible, +! reuse SPDK2 +! zi(i,k) is AGL, right? May not matter if applied only to water grid +! points + if(moninq_fac.lt.0)then + + DO I=1,IM + SPDK2 = 0. + WSPM(i,1) = 0. + DO K = 1, KMPBL ! kmpbl is like a max possible pbl height + if(zi(i,k).le.500.and.zi(i,k+1).gt.500.)then ! find level bracketing 500 m + SPDK2 = SQRT(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)) ! wspd near 500 m + WSPM(i,1) = SPDK2/0.6 ! now the Km limit for 500 m. just store in K=1 + WSPM(i,2) = float(k) ! height of level at gridpoint i. store in K=2 +! if(i.eq.25) print *,' IK ',i,k,' ZI ',zi(i,k), ' WSPM1 +! ',wspm(i,1),' +! KMPBL ',kmpbl,' KPBL ',kpbl(i) + endif + ENDDO + ENDDO ! i + + endif ! moninq_fac < 0 + + + +! +! compute diffusion coefficients below pbl +!> ## Compute diffusion coefficients below the PBL top +!! Below the PBL top, the diffusion coefficients (\f$K_m\f$ and \f$K_h\f$) are calculated according to equation 2 in Hong and Pan (1996) \cite hong_and_pan_1996 where a different value for \f$w_s\f$ (PBL vertical velocity scale) is used depending on the PBL stability. \f$K_h\f$ is calculated from \f$K_m\f$ using the Prandtl number. The calculated diffusion coefficients are checked so that they are bounded by maximum values and the local background diffusion coefficients. + + IF (ALPHA > 0) THEN + do k = 1, kmpbl + do i=1,im + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif + enddo + enddo + + ELSE ! ALPHA <0 + + do i=1,im + do k = 1, kmpbl + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + ! tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested + ! by kg + tem = zi(i,k+1) * (zfac**pfac) * abs( moninq_fac) + +!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W + if(useshape .ge. 1) then + sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) + sz2h=max(sz2h,zfmin) + sz2h=min(sz2h,1.0) + zfac=(1.0-sz2h)**pfac +! smax=0.148 !! max value of this shape function + smax=0.148 !! max value of this shape function + hmax=0.333 !! roughly height if max K + skmax=hmax*(1.0-hmax)**pfac + sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) + sksfc=sksfc*(1-sksfc)**pfac + + zfac=max(zfac,zfmin) + ashape=max(ABS(moninq_fac),0.2) ! should not be smaller than 0.2, otherwise too much adjustment(?) + if(useshape ==1) then + ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) + & *( 1.0 - ashape ) ) + tem = zi(i,k+1) * (zfac) * ashape + endif + + if (useshape == 2) then !only adjus K that is > K_surface_top + ashape1=1.0 + if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ + & (skmax-sksfc) + skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc + tem = zi(i,k+1) * (zfac) ! no adjustment + if (skminusk0 > 0) then ! only adjust K which is > surface top K + tem = skminusk0*ashape1 + HPBL(i)*sksfc + endif + endif + endif ! endif useshape>1 +!!!! END OF CHAGES , WANG W + + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif + enddo !K loop + +! possible modification of first guess DKU, under certain conditions +! (1) this applies only to columns over water + + IF(islimsk(i).eq.0)then ! sea only + +! (2) alpha test +! if alpha < 0, find alpha for each column and do the loop again +! if alpha > 0, we are finished + + + if(alpha.lt.0)then ! variable alpha test +! k-level of layer around 500 m + kLOC = INT(WSPM(i,2)) +! print *,' kLOC ',kLOC,' KPBL ',KPBL(I) + +! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, +! with DKU as +! if alpha = +1 + + if(KPBL(I).gt.kLOC)then + + xDKU = DKU(i,kLOC) ! Km at k-level +! (4) DKU check. +! WSPM(i,1) is the KM cap for the 500-m level. +! if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE. Alpha = +! abs(alpha). No need to recalc. +! if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for +! entire +! column + if(xDKU.ge.WSPM(i,1)) then ! ONLY if DKU at 500-m exceeds +cap, otherwise already done + + WSPM(i,3) = WSPM(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) + !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column + !alpha. cap at 1. ! should never be needed + WSPM(i,4) = min(WSPM(I,3),1.0) ! this is new column alpha. +cap at 1. ! should never be needed +!! recalculate K capped by WSPM(i,1) + do k = 1, kmpbl + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + ! tem = zi(i,k+1) * (zfac**pfac) + tem = zi(i,k+1) * (zfac**pfac) * WSPM(i,4) + + +!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W + if(useshape .ge. 1) then + sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) + sz2h=max(sz2h,zfmin) + sz2h=min(sz2h,1.0) + zfac=(1.0-sz2h)**pfac + smax=0.148 !! max value of this shape function + hmax=0.333 !! roughly height if max K + skmax=hmax*(1.0-hmax)**pfac + sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) + sksfc=sksfc*(1-sksfc)**pfac + + zfac=max(zfac,zfmin) + ashape=max(WSPM(i,4),0.2) !! adjustment coef should not smaller than 0.2 + if(useshape ==1) then + ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) + & *( 1.0 - ashape ) ) + tem = zi(i,k+1) * (zfac) * ashape +! if(k ==5) write(0,*)'min alf, height-depend +! alf',WSPM(i,4),ashape + endif ! endif useshape=1 + + if (useshape == 2) then !only adjus K that is > K_surface_top + ashape1=1.0 + if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ + & (skmax-sksfc) + + skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc + tem = zi(i,k+1) * (zfac) ! no adjustment +! if(k ==5) write(0,*)'before, dku,ashape,ashpe1', +! & tem*wscaleu(i)*vk,ashape,ashape1 + if (skminusk0 > 0) then ! only adjust K which is > surface top K + tem = skminusk0*ashape1 + HPBL(i)*sksfc + endif +! if(k ==5)write(0,*) +! & 'after,dku,k_sfc,skmax,sksfc,zi(2),hpbl' +! & ,tem*wscaleu(i)*vk,WSCALEU(I)*VK*HPBL(i)*sksfc, skmax, +! & sksfc,ZI(I,2),HPBL(I) + + endif ! endif useshape=2 + endif ! endif useshape>1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif + enddo !K loop + endif ! xDKU.ge.WSPM(i,1) + endif ! KPBL(I).ge.kLOC + endif ! alpha < 0 + endif ! islimsk=0 + + enddo !I loop + ENDIF ! ALPHA LOOP + + + + +! +! compute diffusion coefficients based on local scheme above pbl +!> ## Compute diffusion coefficients above the PBL top +!! Diffusion coefficients above the PBL top are computed as a function of local stability (gradient Richardson number), shear, and a length scale from Louis (1979) \cite louis_1979 : +!! \f[ +!! K_{m,h}=l^2f_{m,h}(Ri_g)\left|\frac{\partial U}{\partial z}\right| +!! \f] +!! The functions used (\f$f_{m,h}\f$) depend on the local stability. First, the gradient Richardson number is calculated as +!! \f[ +!! Ri_g=\frac{\frac{g}{T}\frac{\partial \theta_v}{\partial z}}{\frac{\partial U}{\partial z}^2} +!! \f] +!! where \f$U\f$ is the horizontal wind. For the unstable case (\f$Ri_g < 0\f$), the Richardson number-dependent functions are given by +!! \f[ +!! f_h(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.286\sqrt{\left|Ri_g\right|}}\\ +!! \f] +!! \f[ +!! f_m(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.746\sqrt{\left|Ri_g\right|}}\\ +!! \f] +!! For the stable case, the following formulas are used +!! \f[ +!! f_h(Ri_g) = \frac{1}{\left(1 + 5Ri_g\right)^2}\\ +!! \f] +!! \f[ +!! Pr = \frac{K_h}{K_m} = 1 + 2.1Ri_g +!! \f] +!! The source for the formulas used for the Richardson number-dependent functions is unclear. They are different than those used in Hong and Pan (1996) \cite hong_and_pan_1996 as the previous documentation suggests. They follow equation 14 of Louis (1979) \cite louis_1979 for the unstable case, but it is unclear where the values of the coefficients \f$b\f$ and \f$c\f$ from that equation used in this scheme originate. Finally, the length scale, \f$l\f$ is calculated according to the following formula from Hong and Pan (1996) \cite hong_and_pan_1996 +!! \f[ +!! \frac{1}{l} = \frac{1}{kz} + \frac{1}{l_0}\\ +!! \f] +!! \f[ +!! or\\ +!! \f] +!! \f[ +!! l=\frac{l_0kz}{l_0+kz} +!! \f] +!! where \f$l_0\f$ is currently 30 m for stable conditions and 150 m for unstable. Finally, the diffusion coefficients are kept in a range bounded by the background diffusion and the maximum allowable values. + do k = 1, km1 + do i=1,im + if(k >= kpbl(i)) then + bvf2 = g*bf(i,k)*ti(i,k) + ri = max(bvf2/shr2(i,k),rimin) + zk = vk*zi(i,k+1) + if(ri < 0.) then ! unstable regime + rl2 = zk*rlamun/(rlamun+zk) + dk = rl2*rl2*sqrt(shr2(i,k)) + sri = sqrt(-ri) +! dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri)) +! dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri)) + dku(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + dkt(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else ! stable regime + rl2 = zk*rlam/(rlam+zk) +!! tem = rlam * sqrt(0.01*prsi(i,k)) +!! rl2 = zk*tem/(tem+zk) + dk = rl2*rl2*sqrt(shr2(i,k)) + tem1 = dk/(1+5.*ri)**2 +! + if(k >= kpblx(i)) then + prnum = 1.0 + 2.1*ri + prnum = min(prnum,prmax) + else + prnum = 1.0 + endif +! dku(i,k) = xkzmo(i,k) + tem1 * prnum +! dkt(i,k) = xkzo(i,k) + tem1 + dku(i,k) = tem1 * prnum + dkt(i,k) = tem1 + endif +! + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) +! + endif +! + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute components for mass flux mixing by large thermals +!> ## If the PBL is convective, call the mass flux scheme to replace the countergradient terms. +!! If the PBL is convective, the updraft properties are initialized to be the same as the state variables and the subroutine mfpbl is called. + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + tcko(i,k) = t1(i,k) + ucko(i,k) = u1(i,k) + vcko(i,k) = v1(i,k) + xmf(i,k) = 0. + endif + enddo + enddo + do kk = 1, ntrac + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + qcko(i,k,kk) = q1(i,k,kk) + endif + enddo + enddo + enddo +!> For details of the mfpbl subroutine, step into its documentation ::mfpbl + call mfpbl(im,ix,km,ntrac,dt2,pcnvflg, + & zl,zi,thvx,q1,t1,u1,v1,hpbl,kpbl, + & sflux,ustar,wstar,xmf,tcko,qcko,ucko,vcko) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute diffusion coefficients for cloud-top driven diffusion +! if the condition for cloud-top instability is met, +! increase entrainment flux at cloud top +! +!> ## Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs +!! If a stratocumulus layer has been identified in the PBL, the diffusion coefficients in the PBL are modified in the following way. +!! +!! -# First, the criteria for CTEI is checked, using the threshold from equation 13 of Macvean and Mason (1990) \cite macvean_and_mason_1990. If the criteria is met, the cloud top diffusion is increased: +!! \f[ +!! K_h^{Sc} = -c\frac{\Delta F_R}{\rho c_p}\frac{1}{\frac{\partial \theta_v}{\partial z}} +!! \f] +!! where the constant \f$c\f$ is set to 0.2 if the CTEI criterion is not met and 1.0 if it is. +!! +!! -# Calculate the diffusion coefficients due to stratocumulus mixing according to equation 5 in Lock et al. (2000) \cite lock_et_al_2000 for every level below the stratocumulus top using the characteristic stratocumulus velocity scale previously calculated. The diffusion coefficient for momentum is calculated assuming a constant inverse Prandtl number of 0.75. + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = thetae(i,k) - thetae(i,k+1) + tem1 = qtx(i,k) - qtx(i,k+1) + if (tem > 0. .and. tem1 > 0.) then + cteit= cp*tem/(hvap*tem1) + if(cteit > actei) rent(i) = rentf2 + endif + endif + enddo + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem1 = max(bf(i,k),tdzmin) + ckt(i,k) = -rent(i)*radmin(i)/tem1 + cku(i,k) = ckt(i,k) + endif + enddo +! + do k = 1, kmpbl + do i=1,im + if(scuflg(i) .and. k < krad(i)) then + tem1=hrad(i)-zd(i) + tem2=zi(i,k+1)-tem1 + if(tem2 > 0.) then + ptem= tem2/zd(i) + if(ptem.ge.1.) ptem= 1. + ptem= tem2*ptem*sqrt(1.-ptem) + ckt(i,k) = radfac*vk*vrad(i)*ptem + cku(i,k) = 0.75*ckt(i,k) + ckt(i,k) = max(ckt(i,k),dkmin) + ckt(i,k) = min(ckt(i,k),dkmax) + cku(i,k) = max(cku(i,k),dkmin) + cku(i,k) = min(cku(i,k),dkmax) + endif + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!> After \f$K_h^{Sc}\f$ has been determined from the surface to the top of the stratocumulus layer, it is added to the value for the diffusion coefficient calculated previously using surface-based mixing [see equation 6 of Lock et al. (2000) \cite lock_et_al_2000 ]. + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat and moisture +! +!> ## Solve for the temperature and moisture tendencies due to vertical mixing. +!! The tendencies of heat, moisture, and momentum due to vertical diffusion are calculated using a two-part process. First, a solution is obtained using an implicit time-stepping scheme, then the time tendency terms are "backed out". The tridiagonal matrix elements for the implicit solution for temperature and moisture are prepared in this section, with differing algorithms depending on whether the PBL was convective (substituting the mass flux term for counter-gradient term), unstable but not convective (using the computed counter-gradient terms), or stable (no counter-gradient terms). + do i=1,im + ad(i,1) = 1. + a1(i,1) = t1(i,1) + beta(i) * heat(i) + a2(i,1) = q1(i,1,1) + beta(i) * evap(i) + enddo + + if(ntrac >= 2) then + do k = 2, ntrac + is = (k-1) * km + do i = 1, im + a2(i,1+is) = q1(i,1,k) + enddo + enddo + endif +! + do k = 1,km1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + if(pcnvflg(i) .and. k < kpbl(i)) then + tem2 = dsig * rdz + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ad(i,k) = ad(i,k)-au(i,k)-ptem1 + ad(i,k+1) = 1.-al(i,k)+ptem2 + au(i,k) = au(i,k)-ptem1 + al(i,k) = al(i,k)+ptem2 + ptem = tcko(i,k) + tcko(i,k+1) + dsdzt = tem1 * gocp + a1(i,k) = a1(i,k)+dtodsd*dsdzt-ptem1*ptem + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt+ptem2*ptem + ptem = qcko(i,k,1) + qcko(i,k+1,1) + a2(i,k) = a2(i,k) - ptem1 * ptem + a2(i,k+1) = q1(i,k+1,1) + ptem2 * ptem + elseif(ublflg(i) .and. k < kpbl(i)) then + ptem1 = dsig * dktx(i,k) * rdz + tem = 1.0 / hpbl(i) + dsdzt = tem1 * gocp - ptem1 * hgamt(i) * tem + dsdzq = - ptem1 * hgamq(i) * tem + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + a1(i,k) = a1(i,k)+dtodsd*dsdzt + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + a2(i,k) = a2(i,k)+dtodsd*dsdzq + a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq + else + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + dsdzt = tem1 * gocp + a1(i,k) = a1(i,k)+dtodsd*dsdzt + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + a2(i,k+1) = q1(i,k+1,1) + endif +! + enddo + enddo +! + if(ntrac >= 2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km1 + do i = 1, im + if(pcnvflg(i) .and. k < kpbl(i)) then + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + tem = dsig * rdzt(i,k) + ptem = 0.5 * tem * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem1 = qcko(i,k,kk) + qcko(i,k+1,kk) + a2(i,k+is) = a2(i,k+is) - ptem1*tem1 + a2(i,k+1+is)= q1(i,k+1,kk) + ptem2*tem1 + else + a2(i,k+1+is) = q1(i,k+1,kk) + endif + enddo + enddo + enddo + endif +! +! solve tridiagonal problem for heat and moisture +! +!> The tridiagonal system is solved by calling the internal ::tridin subroutine. + call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2) + +! +! recover tendencies of heat and moisture +! +!> After returning with the solution, the tendencies for temperature and moisture are recovered. + do k = 1,km + do i = 1,im + ttend = (a1(i,k)-t1(i,k)) * rdt + qtend = (a2(i,k)-q1(i,k,1))*rdt + tau(i,k) = tau(i,k)+ttend + rtg(i,k,1) = rtg(i,k,1)+qtend + dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend + enddo + enddo + if(ntrac >= 2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (a2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk)+qtend + enddo + enddo + enddo + endif +! +! compute tke dissipation rate +! +!> ## Calculate heating due to TKE dissipation and add to the tendency for temperature +!! Following Han et al. (2016) \cite Han_2016 , turbulence dissipation contributes to the tendency of temperature in the following way. First, turbulence dissipation is calculated by equation 17 of Han et al. (2016) \cite Han_2016 for the PBL and equation 16 for the surface layer. + if(dspheat) then +! + do k = 1,km1 + do i = 1,im + diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) +! diss(i,k) = dku(i,k)*shr2(i,k) + enddo + enddo +! +! add dissipative heating at the first model layer +! +!> Next, the temperature tendency is updated following equation 14. + do i = 1,im + tem = govrth(i)*sflux(i) + tem1 = tem + stress(i)*spd1(i)/zl(i,1) + tem2 = 0.5 * (tem1+diss(i,1)) + tem2 = max(tem2, 0.) + ttend = tem2 / cp + if (alpha .gt. 0.0) then + tau(i,1) = tau(i,1)+0.5*ttend + else + tau(i,1) = tau(i,1)+0.7*ttend ! in HWRF/HMON, use 0.7 + endif + enddo +! +! add dissipative heating above the first model layer +! + do k = 2,km1 + do i = 1,im + tem = 0.5 * (diss(i,k-1)+diss(i,k)) + tem = max(tem, 0.) + ttend = tem / cp + tau(i,k) = tau(i,k) + 0.5*ttend + enddo + enddo +! + endif +! +! compute tridiagonal matrix elements for momentum +! +!> ## Solve for the horizontal momentum tendencies and add them to the output tendency terms +!! As with the temperature and moisture tendencies, the horizontal momentum tendencies are calculated by solving tridiagonal matrices after the matrices are prepared in this section. + do i=1,im + ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + a1(i,1) = u1(i,1) + a2(i,1) = v1(i,1) + enddo +! + do k = 1,km1 + do i=1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig*dku(i,k)*rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + if(pcnvflg(i) .and. k < kpbl(i)) then + tem2 = dsig * rdz + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ad(i,k) = ad(i,k)-au(i,k)-ptem1 + ad(i,k+1) = 1.-al(i,k)+ptem2 + au(i,k) = au(i,k)-ptem1 + al(i,k) = al(i,k)+ptem2 + ptem = ucko(i,k) + ucko(i,k+1) + a1(i,k) = a1(i,k) - ptem1 * ptem + a1(i,k+1) = u1(i,k+1) + ptem2 * ptem + ptem = vcko(i,k) + vcko(i,k+1) + a2(i,k) = a2(i,k) - ptem1 * ptem + a2(i,k+1) = v1(i,k+1) + ptem2 * ptem + else + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + a1(i,k+1) = u1(i,k+1) + a2(i,k+1) = v1(i,k+1) + endif +! + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) +! +! recover tendencies of momentum +! +!> Finally, the tendencies are recovered from the tridiagonal solutions. + do k = 1,km + do i = 1,im + utend = (a1(i,k)-u1(i,k))*rdt + vtend = (a2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k) + utend + dv(i,k) = dv(i,k) + vtend + dusfc(i) = dusfc(i) + conw*del(i,k)*utend + dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend +! +! for dissipative heating for ecmwf model +! +! tem1 = 0.5*(a1(i,k)+u1(i,k)) +! tem2 = 0.5*(a2(i,k)+v1(i,k)) +! diss(i,k) = -(tem1*utend+tem2*vtend) +! diss(i,k) = max(diss(i,k),0.) +! ttend = diss(i,k) / cp +! tau(i,k) = tau(i,k) + ttend +! + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end subroutine hedmf_hafs_run +!> @} +!> @} + + end module hedmf From db8ed27b2a5c9a46272540e488e3cda5d53e3444 Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Mon, 9 Dec 2019 22:09:14 +0000 Subject: [PATCH 02/16] Adding the moninedmf_hafs.meta file --- physics/moninedmf_hafs.meta | 526 ++++++++++++++++++++++++++++++++++++ 1 file changed, 526 insertions(+) create mode 100644 physics/moninedmf_hafs.meta diff --git a/physics/moninedmf_hafs.meta b/physics/moninedmf_hafs.meta new file mode 100644 index 000000000..6a7b0c7ed --- /dev/null +++ b/physics/moninedmf_hafs.meta @@ -0,0 +1,526 @@ +[ccpp-arg-table] + name = hedmf_init + type = scheme +[moninq_fac] + standard_name = atmosphere_diffusivity_coefficient_factor + long_name = multiplicative constant for atmospheric diffusivities + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = hedmf_run + type = scheme +[ix] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_vertical_diffusion_tracers + long_name = number of tracers to diffuse vertically + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = cloud condensate index in tracer array + units = index + dimensions = () + type = integer + intent = in + optional = F +[dv] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tau] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rtg] + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme + units = kg kg-1 s-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = inout + optional = F +[u1] + standard_name = x_wind + long_name = x component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind + long_name = y component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature + long_name = layer mean air temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = vertically_diffused_tracer_concentration + long_name = tracer concentration diffused by PBL scheme + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[swh] + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step + long_name = total sky shortwave heating rate + units = K s-1 + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in + optional = F +[hlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step + long_name = total sky longwave heating rate + units = K s-1 + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in + optional = F +[xmu] + standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes + long_name = zenith angle temporal adjustment factor for shortwave + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[psk] + standard_name = dimensionless_exner_function_at_lowest_model_interface + long_name = dimensionless Exner function at the surface interface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rbsoil] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[u10m] + standard_name = x_wind_at_10m + long_name = x component of wind at 10 m + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v10m] + standard_name = y_wind_at_10m + long_name = y component of wind at 10 m + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum + long_name = Monin-Obukhov similarity function for momentum + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[fh] + standard_name = Monin_Obukhov_similarity_function_for_heat + long_name = Monin-Obukhov similarity function for heat + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsea] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[heat] + standard_name = kinematic_surface_upward_sensible_heat_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[stress] + standard_name = surface_wind_stress + long_name = surface wind stress + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[spd1] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = PBL top model level index + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = pres(k) - pres(k+1) + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = Exner function at layers + units = none + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[delt] + standard_name = time_step_for_physics + long_name = time step for physics + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dspheat] + standard_name = flag_TKE_dissipation_heating + long_name = flag for using TKE dissipation heating + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dusfc] + standard_name = instantaneous_surface_x_momentum_flux + long_name = x momentum flux + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc] + standard_name = instantaneous_surface_y_momentum_flux + long_name = y momentum flux + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtsfc] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dqsfc] + standard_name = instantaneous_surface_upward_latent_heat_flux + long_name = surface upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[hgamt] + standard_name = countergradient_mixing_term_for_temperature + long_name = countergradient mixing term for temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[hgamq] + standard_name = countergradient_mixing_term_for_water_vapor + long_name = countergradient mixing term for water vapor + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dkt] + standard_name = atmosphere_heat_diffusivity + long_name = diffusivity for heat + units = m2 s-1 + dimensions = (horizontal_dimension,vertical_dimension_minus_one) + type = real + kind = kind_phys + intent = out + optional = F +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[xkzm_m] + standard_name = atmosphere_momentum_diffusivity_background + long_name = background value of momentum diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[xkzm_h] + standard_name = atmosphere_heat_diffusivity_background + long_name = background value of heat diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[xkzm_s] + standard_name = diffusivity_background_sigma_level + long_name = sigma level threshold for background diffusivity + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = flag for printing diagnostics to output + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[xkzminv] + standard_name = atmosphere_heat_diffusivity_background_maximum + long_name = maximum background value of heat diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[moninq_fac] + standard_name = atmosphere_diffusivity_coefficient_factor + long_name = multiplicative constant for atmospheric diffusivities + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[islimsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From 942889ab0acace519254712cb4e14b6aaf3e0415 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 10 Dec 2019 11:58:48 -0700 Subject: [PATCH 03/16] add hurricane-specific code to moninedmf.f --- physics/moninedmf.f | 366 ++++++++-- physics/moninedmf.meta | 43 ++ physics/moninedmf_hafs.f | 1459 -------------------------------------- 3 files changed, 348 insertions(+), 1520 deletions(-) delete mode 100644 physics/moninedmf_hafs.f diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 1084aa426..a9532857c 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -64,7 +64,8 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & - & xkzminv,moninq_fac,errmsg,errflg) + & xkzminv,moninq_fac,hurr_pbl,islimsk,var_ric, & + & coef_ric_l,coef_ric_s,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -74,14 +75,15 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! ! arguments ! - logical, intent(in) :: lprnt - integer, intent(in) :: ipr + logical, intent(in) :: lprnt, hurr_pbl + integer, intent(in) :: ipr, islimsk(im) integer, intent(in) :: ix, im, km, ntrac, ntcw, kinver(im) integer, intent(out) :: kpbl(im) ! real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s - real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac + real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac, var_ric, & + & coef_ric_l, coef_ric_s real(kind=kind_phys), intent(inout) :: dv(im,km), du(im,km), & & tau(im,km), rtg(im,km,ntrac) real(kind=kind_phys), intent(in) :: & @@ -180,7 +182,15 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & ptem, ptem1, ptem2, tx1(im), tx2(im) ! real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, - & cldtime + & cldtime, ttend_fac + + !! for hurricane application + real(kind=kind_phys) wspm(im,km-1) + integer kLOC ! RGF + real :: xDKU ! RGF + + integer, parameter :: useshape=2!0-- no change, original ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) + real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax cc parameter(gravi=1.0/grav) parameter(g=grav) @@ -211,6 +221,8 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & parameter (zstblmax = 2500., qlcr=3.5e-5) ! parameter (actei = 0.23) parameter (actei = 0.7) + + c c----------------------------------------------------------------------- c @@ -422,23 +434,48 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & !! The temperature of the thermal is of primary importance. For the initial estimate of the PBL height, the thermal is assumed to have one of two temperatures. If the boundary layer is stable, the thermal is assumed to have a temperature equal to the surface virtual temperature. Otherwise, the thermal is assumed to have the same virtual potential temperature as the lowest model level. For the stable case, the critical bulk Richardson number becomes a function of the wind speed and roughness length, otherwise it is set to a tunable constant. ! compute the pbl height ! - do i=1,im - flg(i) = .false. - rbup(i) = rbsoil(i) -! - if(pblflg(i)) then - thermal(i) = thvx(i,1) - crb(i) = crbcon - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem = max(tem, 1.) - robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn - crb(i) = 0.16 * (tem1 ** (-0.18)) - crb(i) = max(min(crb(i), crbmax), crbmin) - endif - enddo + if (.not. hurr_pbl) then + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + ! + if(pblflg(i)) then + thermal(i) = thvx(i,1) + crb(i) = crbcon + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = max(min(crb(i), crbmax), crbmin) + endif + enddo + else + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + + ! use variable Ri for all conditions + if(pblflg(i)) then + thermal(i) = thvx(i,1) + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + endif + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = crbcon + if (var_ric .eq. 1.) then + if (islimsk(i) .eq. 1) crb(I) = coef_ric_l*(tem1)**(-0.18) + if (islimsk(i) .eq. 0) crb(I) = coef_ric_s*(tem1)**(-0.18) + endif + crb(i) = max(min(crb(i), crbmax), crbmin) + enddo + endif + !> Given the thermal's properties and the critical Richardson number, a loop is executed to find the first level above the surface where the modified Richardson number is greater than the critical Richardson number, using equation 10a from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): !! \f[ !! h = Ri\frac{T_0\left|\vec{v}(h)\right|^2}{g\left(\theta_v(h) - \theta_s\right)} @@ -719,38 +756,223 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & kpbl(i) = 1 endif enddo -! + + +!!! 20150915 WeiguoWang added alpha (moninq_fac) and wind-dependent modification of K by RGF +! ------------------------------------------------------------------------------------- +! begin RGF modifications +! this is version MOD05 + +! RGF determine wspd at roughly 500 m above surface, or as close as possible, +! reuse SPDK2 +! zi(i,k) is AGL, right? May not matter if applied only to water grid points + if(hurr_pbl .and. moninq_fac .lt. 0.0) then + do i=1,im + spdk2 = 0. + wspm(i,1) = 0. + do k = 1, kmpbl ! kmpbl is like a max possible pbl height + if (zi(i,k) .le. 500. .and. zi(i,k+1) .gt. 500.) then ! find level bracketing 500 m + spdk2 = SQRT(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) ! wspd near 500 m + wspm(i,1) = spdkw/0.6 ! now the Km limit for 500 m. just store in K=1 + wspm(i,2) = float(k) ! height of level at gridpoint i. store in K=2 + endif + enddo !k + enddo ! i + endif ! hurr_pbl and moninq_fac < 0 + + ! compute diffusion coefficients below pbl !> ## Compute diffusion coefficients below the PBL top !! Below the PBL top, the diffusion coefficients (\f$K_m\f$ and \f$K_h\f$) are calculated according to equation 2 in Hong and Pan (1996) \cite hong_and_pan_1996 where a different value for \f$w_s\f$ (PBL vertical velocity scale) is used depending on the PBL stability. \f$K_h\f$ is calculated from \f$K_m\f$ using the Prandtl number. The calculated diffusion coefficients are checked so that they are bounded by maximum values and the local background diffusion coefficients. - do k = 1, kmpbl - do i=1,im - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) + if (.not. hurr_pbl) then + do k = 1, kmpbl + do i=1,im + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo - enddo + enddo !i + enddo !k + else + !hurricane PBL case (note that the i and k loop order has been switched) + do i=1, im + do k=1, kmpbl + if (k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * ABS(moninq_fac) + +!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W + if (useshape .ge. 1) then + sz2h=(zi(i,k+1)-zl(i,1))/(hpbl(i)-zl(i,1)) + sz2h=max(sz2h,zfmin) + sz2h=min(sz2h,1.0) + zfac=(1.0-sz2h)**pfac +! smax=0.148 !! max value of this shape function + smax=0.148 !! max value of this shape function + hmax=0.333 !! roughly height if max K + skmax=hmax*(1.0-hmax)**pfac + sksfc=min(zi(i,2)/hpbl(i),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) + sksfc=sksfc*(1-sksfc)**pfac + + zfac=max(zfac,zfmin) + ashape=max(ABS(moninq_fac),0.2) ! should not be smaller than 0.2, otherwise too much adjustment(?) + if (useshape == 1) then + ashape=(1.0 - ((sz2h*zfac/smax)**0.25) *(1.0 - ashape)) + tem = zi(i,k+1) * (zfac) * ashape + elseif (useshape == 2) then !only adjus K that is > K_surface_top + ashape1=1.0 + if (skmax > sksfc) then + ashape1=(skmax*ashape-sksfc)/(skmax-sksfc) + endif + skminusk0 = zi(i,k+1)*zfac - hpbl(i)*sksfc + tem = zi(i,k+1) * (zfac) ! no adjustment + if (skminusk0 > 0) then ! only adjust K which is > surface top K + tem = skminusk0*ashape1 + hpbl(i)*sksfc + endif + endif ! useshape == 1 or 2 + endif ! endif useshape>1 +!!!! END OF CHANGES , WANG W + +!!If alpha >= 0, this is the only modification of K +! if alpha = -1, the above provides the first guess for DKU, based on assumption +! alpha = +1 +! (other values of alpha < 0 can also be applied) +! if alpha > 0, the above applies the alpha suppression factor and we are +! finished + + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif !k < kpbl(i) + enddo !K loop + +! possible modification of first guess DKU, under certain conditions +! (1) this applies only to columns over water + if (islimsk(i) .eq. 0) then ! sea only +! (2) alpha test +! if alpha < 0, find alpha for each column and do the loop again +! if alpha > 0, we are finished + if (moninq_fac .lt. 0.) then ! variable alpha test +! k-level of layer around 500 m + kLOC = INT(wspm(i,2)) +! print *,' kLOC ',kLOC,' KPBL ',KPBL(I) + +! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, with DKU as +! if alpha = +1 + if(kpbl(i) .gt. kLOC) then + xDKU = DKU(i,kLOC) ! Km at k-level +! (4) DKU check. +! WSPM(i,1) is the KM cap for the 500-m level. +! if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE. Alpha = +! abs(alpha). No need to recalc. +! if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for entire +! column + if(xDKU .ge. wspm(i,1)) then ! ONLY if DKU at 500-m exceeds cap, otherwise already done + wspm(i,3) = wspm(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) + !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed + wspm(i,4) = min(wspm(i,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed + !! recalculate K capped by WSPM(i,1) + do k = 1, kmpbl + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * wspm(i,4) +!!! wang use different K shape, options!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! HANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W + if(useshape .ge. 1) then + sz2h=(zi(i,k+1)-zl(i,1))/(hpbl(i)-zl(i,1)) + sz2h=max(sz2h,zfmin) + sz2h=min(sz2h,1.0) + zfac=(1.0-sz2h)**pfac + smax=0.148 !! max value of this shape function + hmax=0.333 !! roughly height if max K + skmax=hmax*(1.0-hmax)**pfac + sksfc=min(zi(i,2)/hpbl(i),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) + sksfc=sksfc*(1-sksfc)**pfac + + zfac=max(zfac,zfmin) + ashape=max(wspm(i,4),0.2) !! adjustment coef should not smaller than 0.2 + if(useshape ==1) then + ashape=(1.0 - ((sz2h*zfac/smax)**0.25)* + & (1.0 - ashape)) + tem = zi(i,k+1) * (zfac) * ashape + elseif (useshape == 2) then !only adjus K that is > K_surface_top + ashape1=1.0 + if (skmax > sksfc) then + ashape1=(skmax*ashape-sksfc)/(skmax-sksfc) + endif + skminusk0=zi(i,k+1)*zfac - hpbl(i)*sksfc + tem = zi(i,k+1) * (zfac) ! no adjustment + if (skminusk0 > 0) then ! only adjust K which is > surface top K + tem = skminusk0*ashape1 + HPBL(i)*sksfc + endif + endif ! endif useshape=1 or 2 + endif ! endif useshape>1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif !pblflg + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif ! k < kpbl(i) + enddo ! K loop + endif ! xDKU .ge. wspm(i,1) + endif ! kpbl(i) .ge. kLOC + endif ! moninq_fac < 0 + endif ! islimsk == 0 + enddo ! I loop + endif ! not hurr_pbl ! ! compute diffusion coefficients based on local scheme above pbl !> ## Compute diffusion coefficients above the PBL top @@ -916,16 +1138,32 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !> After \f$K_h^{Sc}\f$ has been determined from the surface to the top of the stratocumulus layer, it is added to the value for the diffusion coefficient calculated previously using surface-based mixing [see equation 6 of Lock et al. (2000) \cite lock_et_al_2000 ]. - do k = 1, kmpbl - do i=1,im - if(scuflg(i)) then - dkt(i,k) = dkt(i,k)+ckt(i,k) - dku(i,k) = dku(i,k)+cku(i,k) - dkt(i,k) = min(dkt(i,k),dkmax) - dku(i,k) = min(dku(i,k),dkmax) - endif + if (.not. hurr_pbl) then + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo enddo - enddo + else + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + !! if K needs to be adjusted by alpha, then no need to add this term + if (moninq_fac == 1.0) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + end if + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo + enddo + endif ! ! compute tridiagonal matrix elements for heat and moisture ! @@ -1067,13 +1305,19 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! add dissipative heating at the first model layer ! !> Next, the temperature tendency is updated following equation 14. + if (hurr_pbl) then + ttend_fac = 0.7 + else + ttend_fac = 0.5 + endif + do i = 1,im tem = govrth(i)*sflux(i) tem1 = tem + stress(i)*spd1(i)/zl(i,1) tem2 = 0.5 * (tem1+diss(i,1)) tem2 = max(tem2, 0.) ttend = tem2 / cp - tau(i,1) = tau(i,1)+0.5*ttend + tau(i,1) = tau(i,1)+ttend_fac*ttend enddo ! ! add dissipative heating above the first model layer @@ -1083,7 +1327,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & tem = 0.5 * (diss(i,k-1)+diss(i,k)) tem = max(tem, 0.) ttend = tem / cp - tau(i,k) = tau(i,k) + 0.5*ttend + tau(i,k) = tau(i,k) + ttend_fac*ttend enddo enddo ! diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 47875640f..7e01d8b53 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -499,6 +499,49 @@ kind = kind_phys intent = in optional = F +[hurr_pbl] + standard_name = flag_hurricane_PBL + long_name = flag for hurricane-specific options in PBL scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[var_ric] + standard_name = flag_variable_bulk_richardson_number + long_name = flag for calculating variable bulk richardson number for hurricane PBL + units = flag + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[coef_ric_l] + standard_name = coefficient_for_variable_bulk_richardson_number_over_land + long_name = coefficient for calculating variable bulk richardson number for hurricane PBL over land + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[coef_ric_s] + standard_name = coefficient_for_variable_bulk_richardson_number_over_ocean + long_name = coefficient for calculating variable bulk richardson number for hurricane PBL over ocean + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/moninedmf_hafs.f b/physics/moninedmf_hafs.f deleted file mode 100644 index d2817c654..000000000 --- a/physics/moninedmf_hafs.f +++ /dev/null @@ -1,1459 +0,0 @@ -!> \file moninedmf.f -!! Contains most of the hybrid eddy-diffusivity mass-flux scheme except for the -!! subroutine that calculates the mass flux and updraft properties. - -!> This module contains the CCPP-compliant hybrid eddy-diffusivity mass-flux -!! scheme for HAFS applications. - -!> \defgroup HEDMF Hybrid Eddy-diffusivity Mass-flux Scheme -!! @{ -!! \brief The Hybrid EDMF scheme is a first-order turbulent transport scheme used for subgrid-scale vertical turbulent mixing in the PBL and above. It blends the traditional first-order approach that has been used and improved over the last several years with a more recent scheme that uses a mass-flux approach to calculate the countergradient diffusion terms. -!! -!! The PBL scheme's main task is to calculate tendencies of temperature, moisture, and momentum due to vertical diffusion throughout the column (not just the PBL). The scheme is an amalg amation of decades of work, starting from the initial first-order PBL scheme of Troen and Mahrt (1986) \cite troen_and_mahrt_1986, implemented according to Hong and Pan (1996) \cite hong_ and_pan_1996 and modified by Han and Pan (2011) \cite han_and_pan_2011 and Han et al. (2015) \cite han_et_al_2015 to include top-down mixing due to stratocumulus layers from Lock et al. ( 2000) \cite lock_et_al_2000 and replacement of counter-gradient terms with a mass flux scheme according to Siebesma et al. (2007) \cite siebesma_et_al_2007 and Soares et al. (2004) \cite soares_et_al_2004. Recently, heating due to TKE dissipation was also added according to Han et al. (2015) \cite han_et_al_2015. -!! -!! \section diagram Calling Hierarchy Diagram -!! \image html Hybrid_EDMF_Flowchart.png "Diagram depicting how the Hybrid EDMF PBL scheme is called from the GSM physics time loop" height=2cm -!! \section intraphysics Intraphysics Communication -!! This space is reserved for a description of how this scheme uses information from other scheme types and/or how information calculated in this scheme is used in other scheme types. -!> \brief This subroutine contains all of logic for the Hybrid EDMF PBL scheme except for the calculation of the updraft properties and mass flux. -!! -!! The scheme works on a basic level by calculating background diffusion coefficients and updating them according to which processes are occurring in the column. The most important difference in diffusion coefficients occurs between those levels in the PBL and those above the PBL, so the PBL height calculation is of utmost importance. An initial estimate is calculated in a "predictor" step in order to calculate Monin-Obukhov similarity values an d a corrector step recalculates the PBL height based on updated surface thermal characteristics. Using the PBL height and the similarity parameters, the diffusion coefficients are updated below the PBL top based on Hong and Pan (1996) \cite hong_and_pan_1996 (including counter-gradient terms). Diffusion coefficients in the free troposphere (above the PBL top) are calculated according to Louis (1979) \cite louis_1979 with updated Richardson number -dependent functions. If it is diagnosed that PBL top-down mixing is occurring according to Lock et al. (2000) \cite lock_et_al_2000 , then then diffu sion coefficients are updated accordingly. Finally, for convective boundary layers (defined as when the Obukhov length exceeds a threshold), the count er-gradient terms are replaced using the mass flux scheme of Siebesma et al. (2007) \cite siebesma_et_al_2007 . In order to return time tendencies, a fully implicit solution is found using tridiagonal matrices, and time tendencies are "backed out." Before returning, the time tendency of temperature is updated to reflect heating due to TKE dissipation following Han et al. (2015) \cite han_et_al_2015 . -!! -!! WeiGuo Wang updated the scheme for HAFS in July, 2019. - - module hedmf - - contains - -!> \section arg_table_hedmf_init Argument Table -!! \htmlinclude hedmf_init.html -!! - subroutine hedmf_init (moninq_fac,errmsg,errflg) - use machine, only : kind_phys - implicit none - real(kind=kind_phys), intent(in ) :: moninq_fac - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (moninq_fac == 0) then - errflg = 1 - write(errmsg,'(*(a))') 'Logic error: moninq_fac == 0', - & ' is incompatible with hedmf' - end if - end subroutine hedmf_init - - subroutine hedmf_finalize () - end subroutine hedmf_finalize - - -!> \defgroup HEDMF GFS Hybrid Eddy-Diffusivity Mass-Flux (HEDMF) Scheme Module -!! @{ -!! \brief This subroutine contains all of logic for the -!! Hybrid EDMF PBL scheme except for the calculation of -!! the updraft properties and mass flux. -!! -!> \section arg_table_hedmf_run Argument Table -!! \htmlinclude hedmf_run.html -!! -!! \section general_edmf GFS Hybrid EDMF General Algorithm -!! -# Compute preliminary variables from input arguments. -!! -# Calculate the first estimate of the PBL height ("Predictor step"). -!! -# Calculate Monin-Obukhov similarity parameters. -!! -# Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). -!! -# Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion. -!! -# Calculate the inverse Prandtl number. -!! -# Compute diffusion coefficients below the PBL top. -!! -# Compute diffusion coefficients above the PBL top. -!! -# If the PBL is convective, call the mass flux scheme to replace the countergradient terms. -!! -# Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs. -!! -# Solve for the temperature and moisture tendencies due to vertical mixing. -!! -# Calculate heating due to TKE dissipation and add to the tendency for temperature. -!! -# Solve for the horizontal momentum tendencies and add them to output tendency terms. -!! \section detailed_hedmf GFS Hybrid HEDMF Detailed Algorithm -!! @{ - subroutine hedmf_hafs_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & - & u1,v1,t1,q1,swh,hlw,xmu, & - & psk,rbsoil,zorl,u10m,v10m,fm,fh, & - & tsea,heat,evap,stress,spd1,kpbl, & - & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & - & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & - & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & - & xkzminv,moninq_fac,islimsk,errmsg,errflg) -! - use machine , only : kind_phys - use funcphys , only : fpvs - use physcons, grav => con_g, rd => con_rd, cp => con_cp - &, hvap => con_hvap, fv => con_fvirt - implicit none -! -! arguments -! - logical, intent(in) :: lprnt - integer, intent(in) :: ipr - integer, intent(in) :: ix, im, km, ntrac, ntcw, kinver(im) - integer, intent(out) :: kpbl(im) - -! - real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s - real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac - real(kind=kind_phys), intent(inout) :: dv(im,km), du(im,km), & - & tau(im,km), rtg(im,km,ntrac) - real(kind=kind_phys), intent(in) :: & - & u1(ix,km), v1(ix,km), & - & t1(ix,km), q1(ix,km,ntrac), & - & swh(ix,km), hlw(ix,km), & - & xmu(im), psk(im), & - & rbsoil(im), zorl(im), & - & u10m(im), v10m(im), & - & fm(im), fh(im), & - & tsea(im), & - & heat(im), evap(im), & - & stress(im), spd1(im) - real(kind=kind_phys), intent(in) :: & - & prsi(ix,km+1), del(ix,km), & - & prsl(ix,km), prslk(ix,km), & - & phii(ix,km+1), phil(ix,km) - real(kind=kind_phys), intent(out) :: & - & dusfc(im), dvsfc(im), & - & dtsfc(im), dqsfc(im), & - & hpbl(im), dkt(im,km-1) - real(kind=kind_phys), intent(inout) :: & - & hgamt(im), hgamq(im) -! - logical, intent(in) :: dspheat -! flag for tke dissipative heating - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! -! locals - - integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond - integer lcld(im),icld(im),kcld(im),krad(im) - integer kx1(im), kpblx(im) - - integer islimsk(1:im) -! -! real(kind=kind_phys) betaq(im), betat(im), betaw(im), - real(kind=kind_phys) phih(im), phim(im), hpblx(im), & - & rbdn(im), rbup(im), & - & beta(im), sflux(im), & - & z0(im), crb(im), wstar(im), & - & zol(im), ustmin(im), ustar(im), & - & thermal(im),wscale(im), wscaleu(im) -! - real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), & - & qlx(im,km), thetae(im,km), & - & qtx(im,km), bf(im,km-1), diss(im,km), & - & radx(im,km-1), & - & govrth(im), hrad(im), & -! & hradm(im), radmin(im), vrad(im), & - & radmin(im), vrad(im), & - & zd(im), zdd(im), thlvx1(im) -! - real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1), & - & zi(im,km+1), zl(im,km), xkzo(im,km-1), & - & dku(im,km-1), xkzmo(im,km-1), & - & cku(im,km-1), ckt(im,km-1), & - & ti(im,km-1), shr2(im,km-1), & - & al(im,km-1), ad(im,km), & - & au(im,km-1), a1(im,km), & - & a2(im,km*ntrac) -! - real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), & - & ucko(im,km), vcko(im,km), xmf(im,km) -! - real(kind=kind_phys) prinv(im), rent(im) -! - logical pblflg(im), sfcflg(im), scuflg(im), flg(im) - logical ublflg(im), pcnvflg(im) -! -! pcnvflg: true for convective(strongly unstable) pbl -! ublflg: true for unstable but not convective(strongly unstable) pbl -! - real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, - & cfac, conq, cont, conw, - & dk, dkmax, dkmin, - & dq1, dsdz2, dsdzq, dsdzt, - & dsdzu, dsdzv, - & dsig, dt2, dthe1, dtodsd, - & dtodsu, dw2, dw2min, g, - & gamcrq, gamcrt, gocp, - & gravi, f0, - & prnum, prmax, prmin, pfac, crbcon, - & qmin, tdzmin, qtend, crbmin,crbmax, - & rbint, rdt, rdz, qlmin, - & ri, rimin, rl2, rlam, rlamun, - & rone, rzero, sfcfrac, - & spdk2, sri, zol1, zolcr, zolcru, - & robn, ttend, - & utend, vk, vk2, - & ust3, wst3, - & vtend, zfac, vpert, cteit, - & rentf1, rentf2, radfac, - & zfmin, zk, tem, tem1, tem2, - & xkzm, xkzmu, - & ptem, ptem1, ptem2, tx1(im), tx2(im) -! - real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, - & cldtime - -!! for alpha (HAFS) - real(kind=kind_phys) WSPM(IM,KM-1) - integer kLOC ! RGF - real :: xDKU, ALPHA ! RGF - - integer :: useshape - real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax - -cc - parameter(gravi=1.0/grav) - parameter(g=grav) - parameter(gocp=g/cp) - parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa -! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) ! for del in kpa - parameter(rlam=30.0,vk=0.4,vk2=vk*vk) - parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5) - parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) - parameter(crbcon=0.25,crbmin=0.15,crbmax=0.35) - parameter(wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) -! parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.) - parameter(qmin=1.e-8, zfmin=1.e-8,aphi5=5.,aphi16=16.) - parameter(tdzmin=1.e-3,qlmin=1.e-12,f0=1.e-4) - parameter(h1=0.33333333,h2=0.66666667) -! parameter(cldtime=500.,xkzminv=0.3) - parameter(cldtime=500.) -! parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3) -! parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0) - parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0) - parameter(rentf1=0.2,rentf2=1.0,radfac=0.85) - parameter(iun=84) -! -! parameter (zstblmax = 2500., qlcr=1.0e-5) -! parameter (zstblmax = 2500., qlcr=3.0e-5) -! parameter (zstblmax = 2500., qlcr=3.5e-5) -! parameter (zstblmax = 2500., qlcr=1.0e-4) - parameter (zstblmax = 2500., qlcr=3.5e-5) -! parameter (actei = 0.23) - parameter (actei = 0.7) - -! HAFS PBL: height-dependent ALPHA - useshape=2 !0-- no change, origincal ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) - alpha=moninq_fac - - write(0,*)'in PBL,alpha=',alpha - - write(0,*)'islimsk=',(islimsk(i),i=1,im) -c -c----------------------------------------------------------------------- -c - 601 format(1x,' moninp lat lon step hour ',3i6,f6.1) - 602 format(1x,' k',' z',' t',' th', - 1 ' tvh',' q',' u',' v', - 2 ' sp') - 603 format(1x,i5,8f9.1) - 604 format(1x,' sfc',9x,f9.1,18x,f9.1) - 605 format(1x,' k zl spd2 thekv the1v' - 1 ,' thermal rbup') - 606 format(1x,i5,6f8.2) - 607 format(1x,' kpbl hpbl fm fh hgamt', - 1 ' hgamq ws ustar cd ch') - 608 format(1x,i5,9f8.2) - 609 format(1x,' k pr dkt dku ',i5,3f8.2) - 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', - 1 ' sr2 ',2f8.2,2e10.2) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -!> ## Compute preliminary variables from input arguments - -! compute preliminary variables -! - if (ix .lt. im) stop -! -! iprt = 0 -! if(iprt.eq.1) then -!cc latd = 0 -! lond = 0 -! else -!cc latd = 0 -! lond = 0 -! endif -! - dt2 = delt - rdt = 1. / dt2 - km1 = km - 1 - kmpbl = km / 2 -!> - Compute physical height of the layer centers and interfaces from the geopotential height (zi and zl) - do k=1,km - do i=1,im - zi(i,k) = phii(i,k) * gravi - zl(i,k) = phil(i,k) * gravi - enddo - enddo - do i=1,im - zi(i,km+1) = phii(i,km+1) * gravi - enddo -!> - Compute reciprocal of \f$ \Delta z \f$ (rdzt) - do k = 1,km1 - do i=1,im - rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) - enddo - enddo -!> - Compute reciprocal of pressure (tx1, tx2) - do i=1,im - kx1(i) = 1 - tx1(i) = 1.0 / prsi(i,1) - tx2(i) = tx1(i) - enddo -!> - Compute background vertical diffusivities for scalars and momentum (xkzo and xkzmo) - do k = 1,km1 - do i=1,im - xkzo(i,k) = 0.0 - xkzmo(i,k) = 0.0 - if (k < kinver(i)) then -! vertical background diffusivity - ptem = prsi(i,k+1) * tx1(i) - tem1 = 1.0 - ptem - tem1 = tem1 * tem1 * 10.0 - xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) - -! vertical background diffusivity for momentum - if (ptem >= xkzm_s) then - xkzmo(i,k) = xkzm_m - kx1(i) = k + 1 - else - if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) - tem1 = 1.0 - prsi(i,k+1) * tx2(i) - tem1 = tem1 * tem1 * 5.0 - xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1)) - endif - endif - enddo - enddo -! if (lprnt) then -! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) -! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) -! endif -! -! diffusivity in the inversion layer is set to be xkzminv (m^2/s) -!> - The background scalar vertical diffusivity is limited to be less than or equal to xkzminv - do k = 1,kmpbl - do i=1,im -! if(zi(i,k+1) > 200..and.zi(i,k+1) < zstblmax) then - if(zi(i,k+1) > 250.) then - tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.e-5) then - xkzo(i,k) = min(xkzo(i,k),xkzminv) - endif - endif - enddo - enddo -!> - Some output variables and logical flags are initialized - do i = 1,im - z0(i) = 0.01 * zorl(i) - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - wscale(i)= 0. - wscaleu(i)= 0. - kpbl(i) = 1 - hpbl(i) = zi(i,1) - hpblx(i) = zi(i,1) - pblflg(i)= .true. - sfcflg(i)= .true. - if(rbsoil(i) > 0.) sfcflg(i) = .false. - ublflg(i)= .false. - pcnvflg(i)= .false. - scuflg(i)= .true. - if(scuflg(i)) then - radmin(i)= 0. - rent(i) = rentf1 - hrad(i) = zi(i,1) -! hradm(i) = zi(i,1) - krad(i) = 1 - icld(i) = 0 - lcld(i) = km1 - kcld(i) = km1 - zd(i) = 0. - endif - enddo -!> - Compute \f$\theta\f$ (theta), \f$q_l\f$ (qlx), \f$q_t\f$ (qtx), \f$\theta_e\f$ (thetae), \f$\theta_v\f$ (thvx), \f$\theta_{l,v}\f$ (thlvx) - do k = 1,km - do i = 1,im - theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - qlx(i,k) = max(q1(i,k,ntcw),qlmin) - qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) - ptem = qlx(i,k) - ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k)) - thetae(i,k)= theta(i,k)*(1.+ptem1) - thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem) - ptem2 = theta(i,k)-(hvap/cp)*ptem - thlvx(i,k) = ptem2*(1.+fv*qtx(i,k)) - enddo - enddo -!> - Initialize diffusion coefficients to 0 and calculate the total radiative heating rate (dku, dkt, radx) - do k = 1,km1 - do i = 1,im - dku(i,k) = 0. - dkt(i,k) = 0. - dktx(i,k) = 0. - cku(i,k) = 0. - ckt(i,k) = 0. - tem = zi(i,k+1)-zi(i,k) - radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) - enddo - enddo -!> - Set lcld to first index above 2.5km - do i=1,im - flg(i) = scuflg(i) - enddo - do k = 1, km1 - do i=1,im - if(flg(i).and.zl(i,k) >= zstblmax) then - lcld(i)=k - flg(i)=.false. - endif - enddo - enddo -! -! compute virtual potential temp gradient (bf) and winshear square -!> - Compute \f$\frac{\partial \theta_v}{\partial z}\f$ (bf) and the wind shear squared (shr2) - do k = 1, km1 - do i = 1, im - rdz = rdzt(i,k) - bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdz - ti(i,k) = 2./(t1(i,k)+t1(i,k+1)) - dw2 = (u1(i,k)-u1(i,k+1))**2 - & + (v1(i,k)-v1(i,k+1))**2 - shr2(i,k) = max(dw2,dw2min)*rdz*rdz - enddo - enddo -!> - Calculate \f$\frac{g}{\theta}\f$ (govrth), \f$\beta = \frac{\Delta t}{\Delta z}\f$ (beta), \f$u_*\f$ (ustar), total surface flux (sflux), and set pblflag to false if the total surface energy flux is into the surface - do i = 1,im - govrth(i) = g/theta(i,1) - enddo -! - do i=1,im - beta(i) = dt2 / (zi(i,2)-zi(i,1)) - enddo -! - do i=1,im - ustar(i) = sqrt(stress(i)) - enddo -! - do i = 1,im - sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. - enddo -!> ## Calculate the first estimate of the PBL height ("Predictor step") -!! The calculation of the boundary layer height follows Troen and Mahrt (1986) \cite troen_and_mahrt_1986 section 3. The approach is to find the level in the column where a modified bulk Richardson number exceeds a critical value. -!! -!! The temperature of the thermal is of primary importance. For the initial estimate of the PBL height, the thermal is assumed to have one of two temperatures. If the boundary layer is stable, the thermal is assumed to have a temperature equal to the surface virtual temperature. Otherwise, the thermal is assumed to have the same virtual potential temperature as the lowest model level. For the stable case, the critical bulk Richardson number becomes a function of the wind speed and roughness length, otherwise it is set to a tunable constant. -! compute the pbl height -! - do i=1,im - flg(i) = .false. - rbup(i) = rbsoil(i) -! - IF ( ALPHA .GT. 0.0) THEN ! ALPHA - - if(pblflg(i)) then - thermal(i) = thvx(i,1) - crb(i) = crbcon - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem = max(tem, 1.) - robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn - crb(i) = 0.16 * (tem1 ** (-0.18)) - crb(i) = max(min(crb(i), crbmax), crbmin) - endif - - ELSE -! use variable Ri for all conditions - if(pblflg(i)) then - thermal(i) = thvx(i,1) - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - endif - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem = max(tem, 1.) - robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn -! crb(i) = 0.16 * (tem1 ** (-0.18)) - crb(i) = crbcon - IF(islimsk(i).ne.0) crb(I) = 0.16*(tem1)**(-0.18) - IF(islimsk(i).eq.0) crb(I) = 0.25*(tem1)**(-0.18) - crb(i) = max(min(crb(i), crbmax), crbmin) - ENDIF ! ALPHA - - enddo -!> Given the thermal's properties and the critical Richardson number, a loop is executed to find the first level above the surface where the modified Richardson number is greater than the critical Richardson number, using equation 10a from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): -!! \f[ -!! h = Ri\frac{T_0\left|\vec{v}(h)\right|^2}{g\left(\theta_v(h) - \theta_s\right)} -!! \f] -!! where \f$h\f$ is the PBL height, \f$Ri\f$ is the Richardson number, \f$T_0\f$ is the virtual potential temperature near the surface, \f$\left|\vec{v}\right|\f$ is the wind speed, and \f$\theta_s\f$ is for the thermal. Rearranging this equation to calculate the modified Richardson number at each level, k, for comparison with the critical value yields: -!! \f[ -!! Ri_k = gz(k)\frac{\left(\theta_v(k) - \theta_s\right)}{\theta_v(1)*\vec{v}(k)} -!! \f] - do k = 1, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) - rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - flg(i) = rbup(i) > crb(i) - endif - enddo - enddo -!> Once the level is found, some linear interpolation is performed to find the exact height of the boundary layer top (where \f$Ri = Ri_{cr}\f$) and the PBL height and the PBL top index are saved (hpblx and kpblx, respectively) - do i = 1,im - if(kpbl(i) > 1) then - k = kpbl(i) - if(rbdn(i) >= crb(i)) then - rbint = 0. - elseif(rbup(i) <= crb(i)) then - rbint = 1. - else - rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) - endif - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - else - hpbl(i) = zl(i,1) - kpbl(i) = 1 - endif - kpblx(i) = kpbl(i) - hpblx(i) = hpbl(i) - enddo -! -! compute similarity parameters -!> ## Calculate Monin-Obukhov similarity parameters -!! Using the initial guess for the PBL height, Monin-Obukhov similarity parameters are calculated. They are needed to refine the PBL height calculation and for calculating diffusion coefficients. -!! -!! First, calculate the Monin-Obukhov nondimensional stability parameter, commonly referred to as \f$\zeta\f$ using the following equation from Businger et al. (1971) \cite businger_et_al_1971 (equation 28): -!! \f[ -!! \zeta = Ri_{sfc}\frac{F_m^2}{F_h} = \frac{z}{L} -!! \f] -!! where \f$F_m\f$ and \f$F_h\f$ are surface Monin-Obukhov stability functions calculated in sfc_diff.f and \f$L\f$ is the Obukhov length. Then, the nondimensional gradients of momentum and temperature (phim and phih) are calculated using equations 5 and 6 from Hong and Pan (1996) \cite hong_and_pan_1996 depending on the surface layer stability. Then, the velocity scale valid for the surface layer (\f$w_s\f$, wscale) is calculated using equation 3 from Hong and Pan (1996) \cite hong_and_pan_1996. For the neutral and unstable PBL above the surface layer, the convective velocity scale, \f$w_*\f$, is calculated according to: -!! \f[ -!! w_* = \left(\frac{g}{\theta_0}h\overline{w'\theta_0'}\right)^{1/3} -!! \f] -!! and the mixed layer velocity scale is then calculated with equation 6 from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 -!! \f[ -!! w_s = (u_*^3 + 7\epsilon k w_*^3)^{1/3} -!! \f] - do i=1,im - zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) - if(sfcflg(i)) then - zol(i) = min(zol(i),-zfmin) - else - zol(i) = max(zol(i),zfmin) - endif - zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) - if(sfcflg(i)) then -! phim(i) = (1.-aphi16*zol1)**(-1./4.) -! phih(i) = (1.-aphi16*zol1)**(-1./2.) - tem = 1.0 / (1. - aphi16*zol1) - phih(i) = sqrt(tem) - phim(i) = sqrt(phih(i)) - else - phim(i) = 1. + aphi5*zol1 - phih(i) = phim(i) - endif - wscale(i) = ustar(i)/phim(i) - ustmin(i) = ustar(i)/aphi5 - wscale(i) = max(wscale(i),ustmin(i)) - enddo - do i=1,im - if(pblflg(i)) then - if(zol(i) < zolcru .and. kpbl(i) > 1) then - pcnvflg(i) = .true. - else - ublflg(i) = .true. - endif - wst3 = govrth(i)*sflux(i)*hpbl(i) - wstar(i)= wst3**h1 - ust3 = ustar(i)**3. - wscaleu(i) = (ust3+wfac*vk*wst3*sfcfrac)**h1 - wscaleu(i) = max(wscaleu(i),ustmin(i)) - endif - enddo -! -! compute counter-gradient mixing term for heat and moisture -!> ## Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). -!! Next, the counter-gradient terms for temperature and humidity are calculated using equation 4 of Hong and Pan (1996) \cite hong_and_pan_1996 and are used to calculate the "scaled virtual temperature excess near the surface" (equation 9 in Hong and Pan (1996) \cite hong_and_pan_1996) so that the properties of the thermal are updated to recalculate the PBL height. - do i = 1,im - if(ublflg(i)) then - hgamt(i) = min(cfac*heat(i)/wscaleu(i),gamcrt) - hgamq(i) = min(cfac*evap(i)/wscaleu(i),gamcrq) - vpert = hgamt(i) + hgamq(i)*fv*theta(i,1) - vpert = min(vpert,gamcrt) - thermal(i)= thermal(i)+max(vpert,0.) - hgamt(i) = max(hgamt(i),0.0) - hgamq(i) = max(hgamq(i),0.0) - endif - enddo -! -! enhance the pbl height by considering the thermal excess -!> The PBL height calculation follows the same procedure as the predictor step, except that it uses an updated virtual potential temperature for the thermal. - do i=1,im - flg(i) = .true. - if(ublflg(i)) then - flg(i) = .false. - rbup(i) = rbsoil(i) - endif - enddo - do k = 2, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) - rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - flg(i) = rbup(i) > crb(i) - endif - enddo - enddo - do i = 1,im - if(ublflg(i)) then - k = kpbl(i) - if(rbdn(i) >= crb(i)) then - rbint = 0. - elseif(rbup(i) <= crb(i)) then - rbint = 1. - else - rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) - endif - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - if(kpbl(i) <= 1) then - ublflg(i) = .false. - pblflg(i) = .false. - endif - endif - enddo -! -! look for stratocumulus -!> ## Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion -!! - Starting at the PBL top and going downward, if the level is less than 2.5 km and \f$q_l>q_{l,cr}\f$ then set kcld = k (find the cloud top index in the PBL). If no cloud water above the threshold is found, scuflg is set to F. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i) .and. k <= lcld(i)) then - if(qlx(i,k).ge.qlcr) then - kcld(i)=k - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i) .and. kcld(i)==km1) scuflg(i)=.false. - enddo -!> - Starting at the PBL top and going downward, if the level is less than the cloud top, find the level of the minimum radiative heating rate within the cloud. If the level of the minimum is the lowest model level or the minimum radiative heating rate is positive, then set scuflg to F. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i) .and. k <= kcld(i)) then - if(qlx(i,k) >= qlcr) then - if(radx(i,k) < radmin(i)) then - radmin(i)=radx(i,k) - krad(i)=k - endif - else - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i) .and. krad(i) <= 1) scuflg(i)=.false. - if(scuflg(i) .and. radmin(i)>=0.) scuflg(i)=.false. - enddo -!> - Starting at the PBL top and going downward, count the number of levels below the minimum radiative heating rate level that have cloud water above the threshold. If there are none, then set the scuflg to F. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,2,-1 - do i = 1, im - if(flg(i) .and. k <= krad(i)) then - if(qlx(i,k) >= qlcr) then - icld(i)=icld(i)+1 - else - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i) .and. icld(i) < 1) scuflg(i)=.false. - enddo -!> - Find the height of the interface where the minimum in radiative heating rate is located. If this height is less than the second model interface height, then set the scuflg to F. - do i = 1, im - if(scuflg(i)) then - hrad(i) = zi(i,krad(i)+1) -! hradm(i)= zl(i,krad(i)) - endif - enddo -! - do i = 1, im - if(scuflg(i) .and. hrad(i) - Calculate the hypothetical \f$\theta_v\f$ at the minimum radiative heating level that a parcel would reach due to radiative cooling after a typical cloud turnover time spent at that level. - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem = zi(i,k+1)-zi(i,k) - tem1 = cldtime*radmin(i)/tem - thlvx1(i) = thlvx(i,k)+tem1 -! if(thlvx1(i) > thlvx(i,k-1)) scuflg(i)=.false. - endif - enddo -!> - Determine the distance that a parcel would sink downwards starting from the level of minimum radiative heating rate by comparing the hypothetical minimum \f$\theta_v\f$ calculated above with the environmental \f$\theta_v\f$. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i) .and. k <= krad(i))then - if(thlvx1(i) <= thlvx(i,k))then - tem=zi(i,k+1)-zi(i,k) - zd(i)=zd(i)+tem - else - flg(i)=.false. - endif - endif - enddo - enddo -!> - Calculate the cloud thickness, where the cloud top is the in-cloud minimum radiative heating level and the bottom is determined previously. - do i = 1, im - if(scuflg(i))then - kk = max(1, krad(i)+1-icld(i)) - zdd(i) = hrad(i)-zi(i,kk) - endif - enddo -!> - Find the largest between the cloud thickness and the distance of a sinking parcel, then determine the smallest of that number and the height of the minimum in radiative heating rate. Set this number to \f$zd\f$. Using \f$zd\f$, calculate the characteristic velocity scale of cloud-top radiative cooling-driven turbulence. - do i = 1, im - if(scuflg(i))then - zd(i) = max(zd(i),zdd(i)) - zd(i) = min(zd(i),hrad(i)) - tem = govrth(i)*zd(i)*(-radmin(i)) - vrad(i)= tem**h1 - endif - enddo -! -! compute inverse prandtl number -!> ## Calculate the inverse Prandtl number -!! For an unstable PBL, the Prandtl number is calculated according to Hong and Pan (1996) \cite hong_and_pan_1996, equation 10, whereas for a stable boundary layer, the Prandtl number is simply \f$Pr = \frac{\phi_h}{\phi_m}\f$. - do i = 1, im - if(ublflg(i)) then - tem = phih(i)/phim(i)+cfac*vk*sfcfrac - else - tem = phih(i)/phim(i) - endif - prinv(i) = 1.0 / tem - prinv(i) = min(prinv(i),prmax) - prinv(i) = max(prinv(i),prmin) - enddo - do i = 1, im - if(zol(i) > zolcr) then - kpbl(i) = 1 - endif - enddo - -!!! HAFS PBL, Bgin adjustment -! RGF determine wspd at roughly 500 m above surface, or as close as -! possible, -! reuse SPDK2 -! zi(i,k) is AGL, right? May not matter if applied only to water grid -! points - if(moninq_fac.lt.0)then - - DO I=1,IM - SPDK2 = 0. - WSPM(i,1) = 0. - DO K = 1, KMPBL ! kmpbl is like a max possible pbl height - if(zi(i,k).le.500.and.zi(i,k+1).gt.500.)then ! find level bracketing 500 m - SPDK2 = SQRT(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)) ! wspd near 500 m - WSPM(i,1) = SPDK2/0.6 ! now the Km limit for 500 m. just store in K=1 - WSPM(i,2) = float(k) ! height of level at gridpoint i. store in K=2 -! if(i.eq.25) print *,' IK ',i,k,' ZI ',zi(i,k), ' WSPM1 -! ',wspm(i,1),' -! KMPBL ',kmpbl,' KPBL ',kpbl(i) - endif - ENDDO - ENDDO ! i - - endif ! moninq_fac < 0 - - - -! -! compute diffusion coefficients below pbl -!> ## Compute diffusion coefficients below the PBL top -!! Below the PBL top, the diffusion coefficients (\f$K_m\f$ and \f$K_h\f$) are calculated according to equation 2 in Hong and Pan (1996) \cite hong_and_pan_1996 where a different value for \f$w_s\f$ (PBL vertical velocity scale) is used depending on the PBL stability. \f$K_h\f$ is calculated from \f$K_m\f$ using the Prandtl number. The calculated diffusion coefficients are checked so that they are bounded by maximum values and the local background diffusion coefficients. - - IF (ALPHA > 0) THEN - do k = 1, kmpbl - do i=1,im - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo - enddo - - ELSE ! ALPHA <0 - - do i=1,im - do k = 1, kmpbl - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - ! tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested - ! by kg - tem = zi(i,k+1) * (zfac**pfac) * abs( moninq_fac) - -!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W - if(useshape .ge. 1) then - sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) - sz2h=max(sz2h,zfmin) - sz2h=min(sz2h,1.0) - zfac=(1.0-sz2h)**pfac -! smax=0.148 !! max value of this shape function - smax=0.148 !! max value of this shape function - hmax=0.333 !! roughly height if max K - skmax=hmax*(1.0-hmax)**pfac - sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) - sksfc=sksfc*(1-sksfc)**pfac - - zfac=max(zfac,zfmin) - ashape=max(ABS(moninq_fac),0.2) ! should not be smaller than 0.2, otherwise too much adjustment(?) - if(useshape ==1) then - ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) - & *( 1.0 - ashape ) ) - tem = zi(i,k+1) * (zfac) * ashape - endif - - if (useshape == 2) then !only adjus K that is > K_surface_top - ashape1=1.0 - if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ - & (skmax-sksfc) - skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc - tem = zi(i,k+1) * (zfac) ! no adjustment - if (skminusk0 > 0) then ! only adjust K which is > surface top K - tem = skminusk0*ashape1 + HPBL(i)*sksfc - endif - endif - endif ! endif useshape>1 -!!!! END OF CHAGES , WANG W - - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo !K loop - -! possible modification of first guess DKU, under certain conditions -! (1) this applies only to columns over water - - IF(islimsk(i).eq.0)then ! sea only - -! (2) alpha test -! if alpha < 0, find alpha for each column and do the loop again -! if alpha > 0, we are finished - - - if(alpha.lt.0)then ! variable alpha test -! k-level of layer around 500 m - kLOC = INT(WSPM(i,2)) -! print *,' kLOC ',kLOC,' KPBL ',KPBL(I) - -! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, -! with DKU as -! if alpha = +1 - - if(KPBL(I).gt.kLOC)then - - xDKU = DKU(i,kLOC) ! Km at k-level -! (4) DKU check. -! WSPM(i,1) is the KM cap for the 500-m level. -! if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE. Alpha = -! abs(alpha). No need to recalc. -! if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for -! entire -! column - if(xDKU.ge.WSPM(i,1)) then ! ONLY if DKU at 500-m exceeds -cap, otherwise already done - - WSPM(i,3) = WSPM(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) - !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column - !alpha. cap at 1. ! should never be needed - WSPM(i,4) = min(WSPM(I,3),1.0) ! this is new column alpha. -cap at 1. ! should never be needed -!! recalculate K capped by WSPM(i,1) - do k = 1, kmpbl - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - ! tem = zi(i,k+1) * (zfac**pfac) - tem = zi(i,k+1) * (zfac**pfac) * WSPM(i,4) - - -!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W - if(useshape .ge. 1) then - sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) - sz2h=max(sz2h,zfmin) - sz2h=min(sz2h,1.0) - zfac=(1.0-sz2h)**pfac - smax=0.148 !! max value of this shape function - hmax=0.333 !! roughly height if max K - skmax=hmax*(1.0-hmax)**pfac - sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) - sksfc=sksfc*(1-sksfc)**pfac - - zfac=max(zfac,zfmin) - ashape=max(WSPM(i,4),0.2) !! adjustment coef should not smaller than 0.2 - if(useshape ==1) then - ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) - & *( 1.0 - ashape ) ) - tem = zi(i,k+1) * (zfac) * ashape -! if(k ==5) write(0,*)'min alf, height-depend -! alf',WSPM(i,4),ashape - endif ! endif useshape=1 - - if (useshape == 2) then !only adjus K that is > K_surface_top - ashape1=1.0 - if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ - & (skmax-sksfc) - - skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc - tem = zi(i,k+1) * (zfac) ! no adjustment -! if(k ==5) write(0,*)'before, dku,ashape,ashpe1', -! & tem*wscaleu(i)*vk,ashape,ashape1 - if (skminusk0 > 0) then ! only adjust K which is > surface top K - tem = skminusk0*ashape1 + HPBL(i)*sksfc - endif -! if(k ==5)write(0,*) -! & 'after,dku,k_sfc,skmax,sksfc,zi(2),hpbl' -! & ,tem*wscaleu(i)*vk,WSCALEU(I)*VK*HPBL(i)*sksfc, skmax, -! & sksfc,ZI(I,2),HPBL(I) - - endif ! endif useshape=2 - endif ! endif useshape>1 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo !K loop - endif ! xDKU.ge.WSPM(i,1) - endif ! KPBL(I).ge.kLOC - endif ! alpha < 0 - endif ! islimsk=0 - - enddo !I loop - ENDIF ! ALPHA LOOP - - - - -! -! compute diffusion coefficients based on local scheme above pbl -!> ## Compute diffusion coefficients above the PBL top -!! Diffusion coefficients above the PBL top are computed as a function of local stability (gradient Richardson number), shear, and a length scale from Louis (1979) \cite louis_1979 : -!! \f[ -!! K_{m,h}=l^2f_{m,h}(Ri_g)\left|\frac{\partial U}{\partial z}\right| -!! \f] -!! The functions used (\f$f_{m,h}\f$) depend on the local stability. First, the gradient Richardson number is calculated as -!! \f[ -!! Ri_g=\frac{\frac{g}{T}\frac{\partial \theta_v}{\partial z}}{\frac{\partial U}{\partial z}^2} -!! \f] -!! where \f$U\f$ is the horizontal wind. For the unstable case (\f$Ri_g < 0\f$), the Richardson number-dependent functions are given by -!! \f[ -!! f_h(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.286\sqrt{\left|Ri_g\right|}}\\ -!! \f] -!! \f[ -!! f_m(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.746\sqrt{\left|Ri_g\right|}}\\ -!! \f] -!! For the stable case, the following formulas are used -!! \f[ -!! f_h(Ri_g) = \frac{1}{\left(1 + 5Ri_g\right)^2}\\ -!! \f] -!! \f[ -!! Pr = \frac{K_h}{K_m} = 1 + 2.1Ri_g -!! \f] -!! The source for the formulas used for the Richardson number-dependent functions is unclear. They are different than those used in Hong and Pan (1996) \cite hong_and_pan_1996 as the previous documentation suggests. They follow equation 14 of Louis (1979) \cite louis_1979 for the unstable case, but it is unclear where the values of the coefficients \f$b\f$ and \f$c\f$ from that equation used in this scheme originate. Finally, the length scale, \f$l\f$ is calculated according to the following formula from Hong and Pan (1996) \cite hong_and_pan_1996 -!! \f[ -!! \frac{1}{l} = \frac{1}{kz} + \frac{1}{l_0}\\ -!! \f] -!! \f[ -!! or\\ -!! \f] -!! \f[ -!! l=\frac{l_0kz}{l_0+kz} -!! \f] -!! where \f$l_0\f$ is currently 30 m for stable conditions and 150 m for unstable. Finally, the diffusion coefficients are kept in a range bounded by the background diffusion and the maximum allowable values. - do k = 1, km1 - do i=1,im - if(k >= kpbl(i)) then - bvf2 = g*bf(i,k)*ti(i,k) - ri = max(bvf2/shr2(i,k),rimin) - zk = vk*zi(i,k+1) - if(ri < 0.) then ! unstable regime - rl2 = zk*rlamun/(rlamun+zk) - dk = rl2*rl2*sqrt(shr2(i,k)) - sri = sqrt(-ri) -! dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri)) -! dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri)) - dku(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) - dkt(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) - else ! stable regime - rl2 = zk*rlam/(rlam+zk) -!! tem = rlam * sqrt(0.01*prsi(i,k)) -!! rl2 = zk*tem/(tem+zk) - dk = rl2*rl2*sqrt(shr2(i,k)) - tem1 = dk/(1+5.*ri)**2 -! - if(k >= kpblx(i)) then - prnum = 1.0 + 2.1*ri - prnum = min(prnum,prmax) - else - prnum = 1.0 - endif -! dku(i,k) = xkzmo(i,k) + tem1 * prnum -! dkt(i,k) = xkzo(i,k) + tem1 - dku(i,k) = tem1 * prnum - dkt(i,k) = tem1 - endif -! - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) -! - endif -! - enddo - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute components for mass flux mixing by large thermals -!> ## If the PBL is convective, call the mass flux scheme to replace the countergradient terms. -!! If the PBL is convective, the updraft properties are initialized to be the same as the state variables and the subroutine mfpbl is called. - do k = 1, km - do i = 1, im - if(pcnvflg(i)) then - tcko(i,k) = t1(i,k) - ucko(i,k) = u1(i,k) - vcko(i,k) = v1(i,k) - xmf(i,k) = 0. - endif - enddo - enddo - do kk = 1, ntrac - do k = 1, km - do i = 1, im - if(pcnvflg(i)) then - qcko(i,k,kk) = q1(i,k,kk) - endif - enddo - enddo - enddo -!> For details of the mfpbl subroutine, step into its documentation ::mfpbl - call mfpbl(im,ix,km,ntrac,dt2,pcnvflg, - & zl,zi,thvx,q1,t1,u1,v1,hpbl,kpbl, - & sflux,ustar,wstar,xmf,tcko,qcko,ucko,vcko) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute diffusion coefficients for cloud-top driven diffusion -! if the condition for cloud-top instability is met, -! increase entrainment flux at cloud top -! -!> ## Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs -!! If a stratocumulus layer has been identified in the PBL, the diffusion coefficients in the PBL are modified in the following way. -!! -!! -# First, the criteria for CTEI is checked, using the threshold from equation 13 of Macvean and Mason (1990) \cite macvean_and_mason_1990. If the criteria is met, the cloud top diffusion is increased: -!! \f[ -!! K_h^{Sc} = -c\frac{\Delta F_R}{\rho c_p}\frac{1}{\frac{\partial \theta_v}{\partial z}} -!! \f] -!! where the constant \f$c\f$ is set to 0.2 if the CTEI criterion is not met and 1.0 if it is. -!! -!! -# Calculate the diffusion coefficients due to stratocumulus mixing according to equation 5 in Lock et al. (2000) \cite lock_et_al_2000 for every level below the stratocumulus top using the characteristic stratocumulus velocity scale previously calculated. The diffusion coefficient for momentum is calculated assuming a constant inverse Prandtl number of 0.75. - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem = thetae(i,k) - thetae(i,k+1) - tem1 = qtx(i,k) - qtx(i,k+1) - if (tem > 0. .and. tem1 > 0.) then - cteit= cp*tem/(hvap*tem1) - if(cteit > actei) rent(i) = rentf2 - endif - endif - enddo - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem1 = max(bf(i,k),tdzmin) - ckt(i,k) = -rent(i)*radmin(i)/tem1 - cku(i,k) = ckt(i,k) - endif - enddo -! - do k = 1, kmpbl - do i=1,im - if(scuflg(i) .and. k < krad(i)) then - tem1=hrad(i)-zd(i) - tem2=zi(i,k+1)-tem1 - if(tem2 > 0.) then - ptem= tem2/zd(i) - if(ptem.ge.1.) ptem= 1. - ptem= tem2*ptem*sqrt(1.-ptem) - ckt(i,k) = radfac*vk*vrad(i)*ptem - cku(i,k) = 0.75*ckt(i,k) - ckt(i,k) = max(ckt(i,k),dkmin) - ckt(i,k) = min(ckt(i,k),dkmax) - cku(i,k) = max(cku(i,k),dkmin) - cku(i,k) = min(cku(i,k),dkmax) - endif - endif - enddo - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!> After \f$K_h^{Sc}\f$ has been determined from the surface to the top of the stratocumulus layer, it is added to the value for the diffusion coefficient calculated previously using surface-based mixing [see equation 6 of Lock et al. (2000) \cite lock_et_al_2000 ]. - do k = 1, kmpbl - do i=1,im - if(scuflg(i)) then - dkt(i,k) = dkt(i,k)+ckt(i,k) - dku(i,k) = dku(i,k)+cku(i,k) - dkt(i,k) = min(dkt(i,k),dkmax) - dku(i,k) = min(dku(i,k),dkmax) - endif - enddo - enddo -! -! compute tridiagonal matrix elements for heat and moisture -! -!> ## Solve for the temperature and moisture tendencies due to vertical mixing. -!! The tendencies of heat, moisture, and momentum due to vertical diffusion are calculated using a two-part process. First, a solution is obtained using an implicit time-stepping scheme, then the time tendency terms are "backed out". The tridiagonal matrix elements for the implicit solution for temperature and moisture are prepared in this section, with differing algorithms depending on whether the PBL was convective (substituting the mass flux term for counter-gradient term), unstable but not convective (using the computed counter-gradient terms), or stable (no counter-gradient terms). - do i=1,im - ad(i,1) = 1. - a1(i,1) = t1(i,1) + beta(i) * heat(i) - a2(i,1) = q1(i,1,1) + beta(i) * evap(i) - enddo - - if(ntrac >= 2) then - do k = 2, ntrac - is = (k-1) * km - do i = 1, im - a2(i,1+is) = q1(i,1,k) - enddo - enddo - endif -! - do k = 1,km1 - do i = 1,im - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) - rdz = rdzt(i,k) - tem1 = dsig * dkt(i,k) * rdz - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! - if(pcnvflg(i) .and. k < kpbl(i)) then - tem2 = dsig * rdz - ptem = 0.5 * tem2 * xmf(i,k) - ptem1 = dtodsd * ptem - ptem2 = dtodsu * ptem - ad(i,k) = ad(i,k)-au(i,k)-ptem1 - ad(i,k+1) = 1.-al(i,k)+ptem2 - au(i,k) = au(i,k)-ptem1 - al(i,k) = al(i,k)+ptem2 - ptem = tcko(i,k) + tcko(i,k+1) - dsdzt = tem1 * gocp - a1(i,k) = a1(i,k)+dtodsd*dsdzt-ptem1*ptem - a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt+ptem2*ptem - ptem = qcko(i,k,1) + qcko(i,k+1,1) - a2(i,k) = a2(i,k) - ptem1 * ptem - a2(i,k+1) = q1(i,k+1,1) + ptem2 * ptem - elseif(ublflg(i) .and. k < kpbl(i)) then - ptem1 = dsig * dktx(i,k) * rdz - tem = 1.0 / hpbl(i) - dsdzt = tem1 * gocp - ptem1 * hgamt(i) * tem - dsdzq = - ptem1 * hgamq(i) * tem - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - a1(i,k) = a1(i,k)+dtodsd*dsdzt - a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt - a2(i,k) = a2(i,k)+dtodsd*dsdzq - a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq - else - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - dsdzt = tem1 * gocp - a1(i,k) = a1(i,k)+dtodsd*dsdzt - a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt - a2(i,k+1) = q1(i,k+1,1) - endif -! - enddo - enddo -! - if(ntrac >= 2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km1 - do i = 1, im - if(pcnvflg(i) .and. k < kpbl(i)) then - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) - tem = dsig * rdzt(i,k) - ptem = 0.5 * tem * xmf(i,k) - ptem1 = dtodsd * ptem - ptem2 = dtodsu * ptem - tem1 = qcko(i,k,kk) + qcko(i,k+1,kk) - a2(i,k+is) = a2(i,k+is) - ptem1*tem1 - a2(i,k+1+is)= q1(i,k+1,kk) + ptem2*tem1 - else - a2(i,k+1+is) = q1(i,k+1,kk) - endif - enddo - enddo - enddo - endif -! -! solve tridiagonal problem for heat and moisture -! -!> The tridiagonal system is solved by calling the internal ::tridin subroutine. - call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2) - -! -! recover tendencies of heat and moisture -! -!> After returning with the solution, the tendencies for temperature and moisture are recovered. - do k = 1,km - do i = 1,im - ttend = (a1(i,k)-t1(i,k)) * rdt - qtend = (a2(i,k)-q1(i,k,1))*rdt - tau(i,k) = tau(i,k)+ttend - rtg(i,k,1) = rtg(i,k,1)+qtend - dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend - dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend - enddo - enddo - if(ntrac >= 2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km - do i = 1, im - qtend = (a2(i,k+is)-q1(i,k,kk))*rdt - rtg(i,k,kk) = rtg(i,k,kk)+qtend - enddo - enddo - enddo - endif -! -! compute tke dissipation rate -! -!> ## Calculate heating due to TKE dissipation and add to the tendency for temperature -!! Following Han et al. (2016) \cite Han_2016 , turbulence dissipation contributes to the tendency of temperature in the following way. First, turbulence dissipation is calculated by equation 17 of Han et al. (2016) \cite Han_2016 for the PBL and equation 16 for the surface layer. - if(dspheat) then -! - do k = 1,km1 - do i = 1,im - diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) -! diss(i,k) = dku(i,k)*shr2(i,k) - enddo - enddo -! -! add dissipative heating at the first model layer -! -!> Next, the temperature tendency is updated following equation 14. - do i = 1,im - tem = govrth(i)*sflux(i) - tem1 = tem + stress(i)*spd1(i)/zl(i,1) - tem2 = 0.5 * (tem1+diss(i,1)) - tem2 = max(tem2, 0.) - ttend = tem2 / cp - if (alpha .gt. 0.0) then - tau(i,1) = tau(i,1)+0.5*ttend - else - tau(i,1) = tau(i,1)+0.7*ttend ! in HWRF/HMON, use 0.7 - endif - enddo -! -! add dissipative heating above the first model layer -! - do k = 2,km1 - do i = 1,im - tem = 0.5 * (diss(i,k-1)+diss(i,k)) - tem = max(tem, 0.) - ttend = tem / cp - tau(i,k) = tau(i,k) + 0.5*ttend - enddo - enddo -! - endif -! -! compute tridiagonal matrix elements for momentum -! -!> ## Solve for the horizontal momentum tendencies and add them to the output tendency terms -!! As with the temperature and moisture tendencies, the horizontal momentum tendencies are calculated by solving tridiagonal matrices after the matrices are prepared in this section. - do i=1,im - ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) - a1(i,1) = u1(i,1) - a2(i,1) = v1(i,1) - enddo -! - do k = 1,km1 - do i=1,im - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) - rdz = rdzt(i,k) - tem1 = dsig*dku(i,k)*rdz - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! - if(pcnvflg(i) .and. k < kpbl(i)) then - tem2 = dsig * rdz - ptem = 0.5 * tem2 * xmf(i,k) - ptem1 = dtodsd * ptem - ptem2 = dtodsu * ptem - ad(i,k) = ad(i,k)-au(i,k)-ptem1 - ad(i,k+1) = 1.-al(i,k)+ptem2 - au(i,k) = au(i,k)-ptem1 - al(i,k) = al(i,k)+ptem2 - ptem = ucko(i,k) + ucko(i,k+1) - a1(i,k) = a1(i,k) - ptem1 * ptem - a1(i,k+1) = u1(i,k+1) + ptem2 * ptem - ptem = vcko(i,k) + vcko(i,k+1) - a2(i,k) = a2(i,k) - ptem1 * ptem - a2(i,k+1) = v1(i,k+1) + ptem2 * ptem - else - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - a1(i,k+1) = u1(i,k+1) - a2(i,k+1) = v1(i,k+1) - endif -! - enddo - enddo -! -! solve tridiagonal problem for momentum -! - call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) -! -! recover tendencies of momentum -! -!> Finally, the tendencies are recovered from the tridiagonal solutions. - do k = 1,km - do i = 1,im - utend = (a1(i,k)-u1(i,k))*rdt - vtend = (a2(i,k)-v1(i,k))*rdt - du(i,k) = du(i,k) + utend - dv(i,k) = dv(i,k) + vtend - dusfc(i) = dusfc(i) + conw*del(i,k)*utend - dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend -! -! for dissipative heating for ecmwf model -! -! tem1 = 0.5*(a1(i,k)+u1(i,k)) -! tem2 = 0.5*(a2(i,k)+v1(i,k)) -! diss(i,k) = -(tem1*utend+tem2*vtend) -! diss(i,k) = max(diss(i,k),0.) -! ttend = diss(i,k) / cp -! tau(i,k) = tau(i,k) + ttend -! - enddo - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - do i = 1, im - hpbl(i) = hpblx(i) - kpbl(i) = kpblx(i) - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - return - end subroutine hedmf_hafs_run -!> @} -!> @} - - end module hedmf From 6a3f0c8ed71799764d4b0ae6b3230217ebea5dc1 Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Wed, 22 Jan 2020 22:40:57 +0000 Subject: [PATCH 04/16] Adding Noah LSM for HAFS --- physics/sflx_hafs.f | 5968 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 5968 insertions(+) create mode 100644 physics/sflx_hafs.f diff --git a/physics/sflx_hafs.f b/physics/sflx_hafs.f new file mode 100644 index 000000000..e69271b38 --- /dev/null +++ b/physics/sflx_hafs.f @@ -0,0 +1,5968 @@ +!>\file sflx_hafs.f +!! This file is the entity of GFS Noah LSM Model(Version 2.7). + +!>\ingroup Noah_LSM +!!\brief This is the entity of GFS Noah LSM model of physics subroutines. +!! It is a soil/veg/snowpack land-surface model to update soil moisture, soil +!! ice, soil temperature, skin temperature, snowpack water content, snowdepth, +!! and all terms of the surface energy balance and surface water balance +!! (excluding input atmospheric forcings of downward radiation and +!! precipitation). +!! +!! The land-surface model component was substantially upgraded from the Oregon +!! State University (OSU) land surface model to EMC's new Noah Land Surface Model +!! (Noah LSM) during the major implementation in the NCEP Global Forecast System +!! (GFS) on May 31, 2005. Forecast System (GFS). The Noah LSM embodies about 10 +!! years of upgrades (see \cite chen_et_al_1996, \cite koren_et_al_1999, +!! \cite ek_et_al_2003) to its ancestor, the OSU LSM. The Noah LSM upgrade includes: +!! - An increase from two (10, 190 cm thick) to four soil layers (10, 30, 60, 100 cm thick) +!! - Addition of frozen soil physics +!! - Add glacial ice treatment +!! - Two snowpack states (SWE, density) +!! - New formulations for infiltration and runoff account for sub-grid variability in precipitation and soil moisture +!! - Revised physics of the snowpack and its influence on surface heat fluxes and albedo +!! - Higher canopy resistance +!! - Spatially varying root depth +!! - Surface fluxes weighted by snow cover fraction +!! - Improved thermal conduction in soil/snow +!! - Improved seasonality of green vegetation cover. +!! - Improved evaporation treatment over bare soil and snowpack +!! +!!\param[in] nsoil integer, number of soil layers (>=2 but <=nsold) +!!\param[in] couple integer, =0:uncoupled (land model only), +!! =1:coupled with parent atmos model +!!\param[in] icein integer, sea-ice flag (=1: sea-ice, =0: land) +!!\param[in] ffrozp real, flag for snow-rain detection (1.=snow, 0.=rain) +!!\param[in] dt real, time step (<3600 sec) +!!\param[in] zlvl real, height abv atmos ground forcing vars (\f$m\f$) +!!\param[in] sldpth real, thickness of each soil layer (\f$m\f$), nsoil +!!\param[in] swdn real, downward SW radiation flux (\f$W/m^2\f$) +!!\param[in] swnet real, downward SW net (dn-up) flux (\f$W/m^2\f$) +!!\param[in] lwdn real, downward LW radiation flux (\f$W/m^2\f$) +!!\param[in] sfcems real, sfc LW emissivity (fractional) +!!\param[in] sfcprs real, pressure at height zlvl above ground(\f$Pa\f$) +!!\param[in] sfctmp real, air temp at height zlvl above ground (\f$K\f$) +!!\param[in] sfcspd real, wind speed at height zlvl above ground (\f$m s^{-1}\f$) +!!\param[in] prcp real, precipitation rate (\f$kgm^{-2}s^{-1}\f$) +!!\param[in] q2 real, mixing ratio at hght zlvl above ground (\f$kgkg^{-1}\f$) +!!\param[in] q2sat real, sat mixing ratio at zlvl above ground (\f$kgkg^{-1}\f$) +!!\param[in] dqsdt2 real, slope of sat specific humidity curve at t=sfctmp (\f$kgkg^{-1}k^{-1}\f$) +!!\param[in] th2 real, air potential temperature at zlvl above ground (\f$K\f$) +!!\param[in] ivegsrc integer, sfc veg type data source UMD or IGBP +!!\param[in] vegtyp integer, vegetation type (integer index) +!!\param[in] soiltyp integer, soil type (integer index) +!!\param[in] slopetyp integer, class of sfc slope (integer index) +!!\param[in] shdmin real, min areal coverage of green veg (fraction) +!!\param[in] shdmax real, max areal coverage of green veg (fraction) +!!\param[in] alb real, background snow-free sfc albedo (fraction) +!!\param[in] snoalb real, max albedo over deep snow (fraction) +!!\param[in] xlaip real, perturbation of leave area index (perturbation) +!!\param[in] lheatstrg logical, flag for canopy heat storage parameterization +!!\param[in,out] tbot real, bottom soil temp (\f$K\f$) (local yearly-mean sfc air temp) +!!\param[in,out] cmc real, canopy moisture content (\f$m\f$) +!!\param[in,out] t1 real, ground/canopy/snowpack eff skin temp (\f$K\f$) +!!\param[in,out] stc real, soil temp (\f$K\f$) +!!\param[in,out] smc real, total soil moisture (vol fraction) +!!\param[in,out] sh2o real, unfrozen soil moisture (vol fraction), note: frozen part = smc-sh2o +!!\param[in,out] sneqv real, water-equivalent snow depth (\f$m\f$), note: snow density = snwqv/snowh +!!\param[in,out] ch real, sfc exchange coeff for heat & moisture (\f$ms^{-1}\f$), +!! note: conductance since it's been mult by wind +!!\param[in,out] cm real, sfc exchange coeff for momentum +!! (\f$ms^{-1}\f$), note: conductance since it's been mult by wind +!!\param[in,out] z0 real, roughness length (\f$m\f$) +!!\param[out] nroot integer, number of root layers +!!\param[out] shdfac real, aeral coverage of green veg (fraction) +!!\param[out] snowh real, snow depth (\f$m\f$) +!!\param[out] albedo real, sfc albedo incl snow effect (fraction) +!!\param[out] eta real, downward latent heat flux (\f$W/m^2\f$) +!!\param[out] sheat real, downward sensible heat flux (\f$W/m^2\f$) +!!\param[out] ec real, canopy water evaporation (\f$W/m^2\f$) +!!\param[out] edir real, direct soil evaporation (\f$W/m^2\f$) +!!\param[out] et real, plant transpiration (\f$W/m^2\f$) +!!\param[out] ett real, total plant transpiration (\f$W/m^2\f$) +!!\param[out] esnow real, sublimation from snowpack (\f$W/m^2\f$) +!!\param[out] drip real, through-fall of precip and/or dew in +!! excess of canopy water-holding capacity (\f$m\f$) +!!\param[out] dew real, dewfall (or frostfall for t<273.15) (\f$m\f$) +!!\param[out] beta real, ratio of actual/potential evap +!!\param[out] etp real, potential evaporation (\f$W/m^2\f$) +!!\param[out] ssoil real, upward soil heat flux (\f$W/m^2\f$) +!!\param[out] flx1 real, precip-snow sfc flux (\f$W/m^2\f$) +!!\param[out] flx2 real, freezing rain latent heat flux (\f$W/m^2\f$) +!!\param[out] flx3 real, phase-change heat flux from snowmelt (\f$W/m^2\f$) +!!\param[out] runoff1 real, surface runoff (\f$ms^{-1}\f$) not infiltrating sfc +!!\param[out] runoff2 real, sub sfc runoff (\f$ms^{-1}\f$) (baseflow) +!!\param[out] runoff3 real, excess of porosity for a given soil layer +!!\param[out] snomlt real, snow melt (\f$m\f$) (water equivalent) +!!\param[out] sncovr real, fractional snow cover +!!\param[out] rc real, canopy resistance (s/m) +!!\param[out] pc real, plant coeff (fraction) where pc*etp=transpi +!!\param[out] rsmin real, minimum canopy resistance (s/m) +!!\param[out] xlai real, leaf area index (dimensionless) +!!\param[out] rcs real, incoming solar rc factor (dimensionless) +!!\param[out] rct real, air temperature rc factor (dimensionless) +!!\param[out] rcq real, atoms vapor press deficit rc factor +!!\param[out] rcsoil real, soil moisture rc factor (dimensionless) +!!\param[out] soilw real, available soil moisture in root zone +!!\param[out] soilm real, total soil column moisture (frozen+unfrozen) (\f$m\f$) +!!\param[out] smcwlt real, wilting point (volumetric) +!!\param[out] smcdry real, dry soil moisture threshold (volumetric) +!!\param[out] smcref real, soil moisture threshold (volumetric) +!!\param[out] smcmax real, porosity (sat val of soil mois) +!>\section general_sflx GFS Noah LSM General Algorithm +!! @{ + subroutine gfssflx_hafs &! --- inputs: + & ( nsoil, couple, icein, ffrozp, dt, zlvl, sldpth, & + & swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, & + & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & + & vegtyp, soiltyp, slopetyp, shdmin, shdmax, alb, snoalb, & + & lheatstrg, usemonalb, rdlai2d, &! --- input/outputs: + & tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm,z0, &! --- outputs: + & nroot, shdfac, snowh, albedo, eta, sheat, ec, & + & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & + & flx1, flx2, flx3, runoff1, runoff2, runoff3, & + & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + +! ===================================================================== ! +! description: ! +! ! +! subroutine sflx - version 2.7: ! +! sub-driver for "noah/osu lsm" family of physics subroutines for a ! +! soil/veg/snowpack land-surface model to update soil moisture, soil ! +! ice, soil temperature, skin temperature, snowpack water content, ! +! snowdepth, and all terms of the surface energy balance and surface ! +! water balance (excluding input atmospheric forcings of downward ! +! radiation and precip) ! +! ! +! usage: ! +! ! +! call sflx_hafs ! +! --- inputs: ! +! ( nsoil, couple, icein, ffrozp, dt, zlvl, sldpth, ! +! swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, ! +! sfcspd, prcp, q2, q2sat, dqsdt2, th2,ivegsrc, ! +! vegtyp, soiltyp, slopetyp, shdmin, shdmax, alb, snoalb, ! +! --- input/outputs: ! +! tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm, ! +! --- outputs: ! +! nroot, shdfac, snowh, albedo, eta, sheat, ec, ! +! edir, et, ett, esnow, drip, dew, beta, etp, ssoil, ! +! flx1, flx2, flx3, runoff1, runoff2, runoff3, ! +! snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, ! +! rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax ) ! +! ! +! ! +! subprograms called: redprm, snow_new, csnow, snfrac, alcalc, ! +! tdfcnd, snowz0, sfcdif, penman, canres, nopac, snopac. ! +! ! +! ! +! program history log: ! +! jun 2003 -- k. mitchell et. al -- created version 2.7 ! +! 200x -- sarah lu modified the code including: ! +! added passing argument, couple; replaced soldn ! +! and solnet by radflx; call sfcdif if couple=0; ! +! apply time filter to stc and tskin; and the ! +! way of namelist inport. ! +! feb 2004 -- m. ek noah v2.7.1 non-linear weighting of snow vs ! +! non-snow covered portions of gridbox ! +! apr 2009 -- y.-t. hou added lw surface emissivity effect, ! +! streamlined and reformatted the code, and ! +! consolidated constents/parameters by using ! +! module physcons, and added program documentation! +! sep 2009 -- s. moorthi minor fixes ! +! nov 2018 -- j. han add canopy heat storage parameterization ! +! jan 2020 -- m. biswas noah lsm in wrf ccpp complaint ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers (>=2 but <=nsold) 1 ! +! couple - integer, =0:uncoupled (land model only) 1 ! +! =1:coupled with parent atmos model ! +! icein - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! ffrozp - real, fractional snow/rain 1 ! +! dt - real, time step (<3600 sec) 1 ! +! zlvl - real, height abv atmos ground forcing vars (m) 1 ! +! sldpth - real, thickness of each soil layer (m) nsoil ! +! swdn - real, downward sw radiation flux (w/m**2) 1 ! +! swnet - real, downward sw net (dn-up) flux (w/m**2) 1 ! +! lwdn - real, downward lw radiation flux (w/m**2) 1 ! +! sfcems - real, sfc lw emissivity (fractional) 1 ! +! sfcprs - real, pressure at height zlvl abv ground(pascals) 1 ! +! sfctmp - real, air temp at height zlvl abv ground (k) 1 ! +! sfcspd - real, wind speed at height zlvl abv ground (m/s) 1 ! +! prcp - real, precip rate (kg m-2 s-1) 1 ! +! q2 - real, mixing ratio at hght zlvl abv grnd (kg/kg) 1 ! +! q2sat - real, sat mixing ratio at zlvl abv grnd (kg/kg) 1 ! +! dqsdt2 - real, slope of sat specific humidity curve at 1 ! +! t=sfctmp (kg kg-1 k-1) ! +! th2 - real, air potential temp at zlvl abv grnd (k) 1 ! +! ivegsrc - integer, sfc veg type data source umd or igbp ! +! vegtyp - integer, vegetation type (integer index) 1 ! +! soiltyp - integer, soil type (integer index) 1 ! +! slopetyp - integer, class of sfc slope (integer index) 1 ! +! shdmin - real, min areal coverage of green veg (fraction) 1 ! +! shdmax - real, max areal coverage of green veg (fraction) 1 ! +! alb - real, bkground snow-free sfc albedo (fraction) 1 ! +! snoalb - real, max albedo over deep snow (fraction) 1 ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! ! +! input/outputs: ! +! tbot - real, bottom soil temp (k) 1 ! +! (local yearly-mean sfc air temp) ! +! cmc - real, canopy moisture content (m) 1 ! +! t1 - real, ground/canopy/snowpack eff skin temp (k) 1 ! +! stc - real, soil temp (k) nsoil ! +! smc - real, total soil moisture (vol fraction) nsoil ! +! sh2o - real, unfrozen soil moisture (vol fraction) nsoil ! +! note: frozen part = smc-sh2o ! +! sneqv - real, water-equivalent snow depth (m) 1 ! +! note: snow density = snwqv/snowh ! +! ch - real, sfc exchange coeff for heat & moisture (m/s)1 ! +! note: conductance since it's been mult by wind ! +! cm - real, sfc exchange coeff for momentum (m/s) 1 ! +! note: conductance since it's been mult by wind ! +! ! +! outputs: ! +! nroot - integer, number of root layers 1 ! +! shdfac - real, aeral coverage of green veg (fraction) 1 ! +! snowh - real, snow depth (m) 1 ! +! albedo - real, sfc albedo incl snow effect (fraction) 1 ! +! eta - real, downward latent heat flux (w/m2) 1 ! +! sheat - real, downward sensible heat flux (w/m2) 1 ! +! ec - real, canopy water evaporation (w/m2) 1 ! +! edir - real, direct soil evaporation (w/m2) 1 ! +! et - real, plant transpiration (w/m2) nsoil ! +! ett - real, total plant transpiration (w/m2) 1 ! +! esnow - real, sublimation from snowpack (w/m2) 1 ! +! drip - real, through-fall of precip and/or dew in excess 1 ! +! of canopy water-holding capacity (m) ! +! dew - real, dewfall (or frostfall for t<273.15) (m) 1 ! +! beta - real, ratio of actual/potential evap 1 ! +! etp - real, potential evaporation (w/m2) 1 ! +! ssoil - real, upward soil heat flux (w/m2) 1 ! +! flx1 - real, precip-snow sfc flux (w/m2) 1 ! +! flx2 - real, freezing rain latent heat flux (w/m2) 1 ! +! flx3 - real, phase-change heat flux from snowmelt (w/m2) 1 ! +! snomlt - real, snow melt (m) (water equivalent) 1 ! +! sncovr - real, fractional snow cover 1 ! +! runoff1 - real, surface runoff (m/s) not infiltrating sfc 1 ! +! runoff2 - real, sub sfc runoff (m/s) (baseflow) 1 ! +! runoff3 - real, excess of porosity for a given soil layer 1 ! +! rc - real, canopy resistance (s/m) 1 ! +! pc - real, plant coeff (fraction) where pc*etp=transpi 1 ! +! rsmin - real, minimum canopy resistance (s/m) 1 ! +! xlai - real, leaf area index (dimensionless) 1 ! +! rcs - real, incoming solar rc factor (dimensionless) 1 ! +! rct - real, air temp rc factor (dimensionless) 1 ! +! rcq - real, atoms vapor press deficit rc factor 1 ! +! rcsoil - real, soil moisture rc factor (dimensionless) 1 ! +! soilw - real, available soil mois in root zone 1 ! +! soilm - real, total soil column mois (frozen+unfrozen) (m)1 ! +! smcwlt - real, wilting point (volumetric) 1 ! +! smcdry - real, dry soil mois threshold (volumetric) 1 ! +! smcref - real, soil mois threshold (volumetric) 1 ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! ! +! ==================== end of description ===================== ! +! + use machine , only : kind_phys +! + use physcons, only : con_cp, con_rd, con_t0c, con_g, con_pi, & + & con_cliq, con_csol, con_hvap, con_hfus, & + & con_sbc +! + implicit none + +! --- constant parameters: +! *** note: some of the constants are different in subprograms and need to +! be consolidated with the standard def in module physcons at sometime +! at the present time, those diverse values are kept temperately to +! provide the same result as the original codes. -- y.t.h. may09 + + integer, parameter :: nsold = 4 !< max soil layers + +! real (kind=kind_phys), parameter :: gs = con_g !< con_g =9.80665 + real (kind=kind_phys), parameter :: gs1 = 9.8 !< con_g in sfcdif + real (kind=kind_phys), parameter :: gs2 = 9.81 !< con_g in snowpack, frh2o + real (kind=kind_phys), parameter :: tfreez = con_t0c !< con_t0c =273.16 + real (kind=kind_phys), parameter :: lsubc = 2.501e+6 !< con_hvap=2.5000e+6 + real (kind=kind_phys), parameter :: lsubf = 3.335e5 !< con_hfus=3.3358e+5 + real (kind=kind_phys), parameter :: lsubs = 2.83e+6 ! ? in sflx, snopac + real (kind=kind_phys), parameter :: elcp = 2.4888e+3 ! ? in penman +! real (kind=kind_phys), parameter :: rd = con_rd ! con_rd =287.05 + real (kind=kind_phys), parameter :: rd1 = 287.04 ! con_rd in sflx, penman, canres + real (kind=kind_phys), parameter :: cp = con_cp ! con_cp =1004.6 + real (kind=kind_phys), parameter :: cp1 = 1004.5 ! con_cp in sflx, canres + real (kind=kind_phys), parameter :: cp2 = 1004.0 ! con_cp in htr +! real (kind=kind_phys), parameter :: cph2o = con_cliq ! con_cliq=4.1855e+3 + real (kind=kind_phys), parameter :: cph2o1 = 4.218e+3 ! con_cliq in penman, snopac + real (kind=kind_phys), parameter :: cph2o2 = 4.2e6 ! con_cliq in hrt *unit diff! + real (kind=kind_phys), parameter :: cpice = con_csol ! con_csol=2.106e+3 + real (kind=kind_phys), parameter :: cpice1 = 2.106e6 ! con_csol in hrt *unit diff! +! real (kind=kind_phys), parameter :: sigma = con_sbc ! con_sbc=5.6704e-8 + real (kind=kind_phys), parameter :: sigma1 = 5.67e-8 ! con_sbc in penman, nopac, snopac + +! --- inputs: + integer, intent(in) :: nsoil, couple, icein, vegtyp, soiltyp, & + & slopetyp, ivegsrc + + real (kind=kind_phys), intent(in) :: ffrozp, dt, zlvl, lwdn, & + & sldpth(nsoil), swdn, swnet, sfcems, sfcprs, sfctmp, & + & sfcspd, prcp, q2, q2sat, dqsdt2, th2, shdmin, shdmax, alb, & + & snoalb, & + + logical, intent(in) :: lheatstrg + logical, intent(in) :: usemonalb + logical, intent(in) :: rdlai2d + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: tbot, cmc, t1, sneqv, & + & stc(nsoil), smc(nsoil), sh2o(nsoil), ch, cm + +! --- outputs: + integer, intent(out) :: nroot + + real (kind=kind_phys), intent(out) :: shdfac, snowh, albedo, & + & eta, sheat, ec, edir, et(nsoil), ett, esnow, drip, dew, & + & beta, etp, ssoil, flx1, flx2, flx3, snomlt, sncovr, & + & runoff1, runoff2, runoff3, rc, pc, rsmin, xlai, rcs, & + & rct, rcq, rcsoil, soilw, soilm, smcwlt, smcdry, smcref, & + & smcmax + +! --- locals: +! real (kind=kind_phys) :: df1h, + real (kind=kind_phys) :: bexp, cfactr, cmcmax, csoil, czil, & + & df1, df1a, dksat, dwsat, dsoil, dtot, frcsno, & + & frcsoi, epsca, fdown, f1, fxexp, frzx, hs, kdt, prcp1, & + & psisat, quartz, rch, refkdt, rr, rgl, rsmax, sndens, & + & sncond, sbeta, sn_new, slope, snup, salp, soilwm, soilww, & + & t1v, t24, t2v, th2v, topt, tsnow, zbot, z0 + + real (kind=kind_phys) :: shdfac0 + real (kind=kind_phys) :: interp_fraction, laimin, laimax, & + & albedomin, albedomax, emissmin, emissmax + real (kind=kind_phys), dimension(nsold) :: rtdis, zsoil + + logical :: frzgra, snowng + + integer :: ice, k, kz +! +! --- parameters for heat storage parametrization +! + real (kind=kind_phys) :: cpx, cpx1, cpfac, xx1, xx2 + real (kind=kind_phys), parameter :: z0min=0.2_kind_phys, & + & z0max=1.0_kind_phys +! +!===> ... begin here +! +! --- ... initialization + + runoff1 = 0.0 + runoff2 = 0.0 + runoff3 = 0.0 + snomlt = 0.0 + +! --- ... define local variable ice to achieve: +! sea-ice case, ice = 1 +! non-glacial land, ice = 0 +! glacial-ice land, ice = -1 +! if vegtype=15 (glacial-ice), re-set ice flag = -1 (glacial-ice) +! note - for open-sea, sflx should *not* have been called. set green +! vegetation fraction (shdfac) = 0. + +!> - Set ice = -1 and green vegetation fraction (shdfac) = 0 for glacial-ice land. + shdfac0 = shdfac + ice = icein + + if(ivegsrc == 2) then + if (vegtyp == 13) then + ice = -1 + shdfac = 0.0 + endif + endif + + if(ivegsrc == 1) then + if (vegtyp == 15) then + ice = -1 + shdfac = 0.0 + endif + endif + +!> - Calculate soil layer depth below ground. + if (ice == 1) then + + shdfac = 0.0 + +!> - For ice, set green vegetation fraction (shdfac) = 0. +!! and set sea-ice layers of equal thickness and sum to 3 meters + + do kz = 1, nsoil + zsoil(kz) = -3.0 * float(kz) / float(nsoil) + enddo + + else + +!> - Otherwise, calculate depth (negative) below ground from top skin sfc to +!! bottom of each soil layer. +! note - sign of zsoil is negative (denoting below ground) + + zsoil(1) = -sldpth(1) + do kz = 2, nsoil + zsoil(kz) = -sldpth(kz) + zsoil(kz-1) + end do + + endif ! end if_ice_block + +! --- ... next is crucial call to set the land-surface parameters, +! including soil-type and veg-type dependent parameters. +! set shdfac=0.0 for bare soil surfaces + +!> - Call redprm() to set the land-surface paramters, +!! including soil-type and veg-type dependent parameters. + call redprm +! if(ivegsrc == 1) then +!only igbp type has urban +!urban +!MKB vegtyp=isurban in HWRF, need to check whether 13/31 and isurban are +!same + if(vegtyp == 13)then +!MKB All these parms below are uncommented in hwrf + shdfac=0.05 + rsmin=400.0 + smcmax = 0.45 + smcref = 0.42 + smcwlt = 0.40 + smcdry = 0.40 +!MKB End of mods +!MKB Commented below +! rsmin=400.0*(1-shdfac0)+40.0*shdfac0 ! gvf +! shdfac=shdfac0 ! gvf +! smcmax = 0.45*(1-shdfac0)+smcmax*shdfac0 +! smcref = 0.42*(1-shdfac0)+smcref*shdfac0 +! smcwlt = 0.40*(1-shdfac0)+smcwlt*shdfac0 +! smcdry = 0.40*(1-shdfac0)+smcdry*shdfac0 +!MKB + if(shdfac >= shdmax )then + embrd = emissmax + if (.not. rdlai2d)then + xlai = laimax + endif + if (.not. usemonalb)then + alb = albedomin + endif + z0brd = z0max + else if ( shdfac <= shdmin )then + embrd = emissmin + if(.not. rdlai2d)then + xlai = laimin + endif + if(.not. usemonalb)then + alb = albedomax + endif + z0brd = z0min + else + + if ( shdmax > shdmin ) then + + interp_fraction = ( shdfac - shdmin ) / (shdmax - shdmin) + ! Bound interp_fraction between 0 and 1 + interp_fraction = min ( interp_fraction, 1.0 ) + interp_fraction = max ( interp_fraction, 0.0 ) + ! Scale Emissivity and LAI between emissmin and emissmax + ! by interp_fraction + embrd = ( ( 1.0 - interp_fraction ) * emissmin ) + & + & ( interp_fraction * emissmax ) + if (.not. rdlai2d)then + xlai = ( ( 1.0 - interp_fraction ) * laimin ) + & + & ( interp_fraction * laimax ) + endif + if (.not. usemonalb)then + alb = ( ( 1.0 - interp_fraction ) * albedomax ) + & + & ( interp_fraction * albedomin ) + endif + z0brd = ( ( 1.0 - interp_fraction ) * z0min ) + & + & ( interp_fraction * z0max ) + + else + + embrd = 0.5 * emissmin + 0.5 * emissmax + if (.not. rdlai2d)then + xlai = 0.5 * laimin + 0.5 * laimax + endif + if (.not. usemonalb)then + alb = 0.5 * albedomin + 0.5 * albedomax + endif + z0brd = 0.5 * z0min + 0.5 * z0max + + endif + + endif + + endif +! endif + +! --- inputs: ! +! ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, ! +! --- outputs: ! +! cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, ! +! sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, ! +! snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, ! +! smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, ! +! z0, czil, xlai, csoil ) ! + +!> - Initialize precipitation logicals. + + snowng = .false. + frzgra = .false. + +!> ---------------------------------------------------------------------- +! if input snowpack is nonzero, then compute snow density "sndens" and +! snow thermal conductivity "sncond" (note that csnow is a function +! subroutine) +! ---------------------------------------------------------------------- + + if (sneqv <= 1.e-7 ) then + sneqv = 0.0 + snowh = 0.0 + snowh = 1.0 + sncond = 1.0 + else + sndens = sneqv / snowh + if(sndens > 1.0) then + fatal_error( 'physical snow depth is less than snow water & + & equiv.' ) + endif + call csnow +! --- inputs: ! +! ( sndens, ! +! sncond ) ! +! --- outputs: ! + endif + + +!> - Determine if it's precipitating and what kind of precipitation it is. +!! if it's precipitating and the air temperature is colder than \f$0^oC\f$, +!! it's snowing! if it's precipitating and the air temperature is warmer than +!! \f$0^oC\f$, but the ground temperature is colder than \f$0^oC\f$, freezing +!! rain is presumed to be falling. + + if (prcp > 0.0) then + +!> snow defined when fraction of frozen precip (ffrozp) > 0.5, +! passed in from model microphysics. + + if (ffrozp > 0.5) then !MKB + snowng = .true. + else + if (t1 <= tfreez) frzgra = .true. + endif + endif + +!> - If either precipitation flag (\a snowng, \a frzgra) is set as true: +! determine new snowfall (converting precipitation rate from +! \f$kg m^{-2} s^{-1}\f$ to a liquid equiv snow depth in meters) +! and add it to the existing snowpack. +!> - Since all precip is added to snowpack, no precip infiltrates +!! into the soil so that \a prcp1 is set to zero. + + if (snowng .or. frzgra) then + sn_new = prcp * dt * 0.001 + sneqv = sneqv + sn_new + prcp1 = 0.0 + endif + +!> - Call snow_new() to update snow density based on new snowfall, +!! using old and new snow. + call snow_new +! --- inputs: ! +! ( sfctmp, sn_new, ! +! --- input/outputs: ! +! snowh, sndens ) ! + +!> - Call csnow() to update snow thermal conductivity. + call csnow +! --- inputs: ! +! ( sndens, ! +! --- outputs: ! +! sncond ) ! + + else + +!> - If precipitation is liquid (rain), hence save in the precip variable +!! that later can wholely or partially infiltrate the soil (along +!! with any canopy "drip" added to this later). + + prcp1 = prcp + + endif ! end if_snowng_block + +! --- ... non-glacial land +! if snow depth=0, set snowcover fraction=0, albedo=snow free albedo. + + if (sneqv == 0.0) then + + sncovr = 0.0 + albedo = alb + sfcems = embrd + if(ua_phys) fgsn = 0.0 + if(ua_phys) fvb = 0.0 + if(ua_phys) fbur = 0.0 + else + +! --- ... determine snow fraction cover. +! determine surface albedo modification due to snowdepth state. +!> - Call snfrac() to calculate snow fraction cover. + call snfrac +! --- inputs: ! +! ( sneqv, snup, salp, snowh, ! +! --- outputs: ! +! sncovr ) ! + call snfrac (sneqv,snup,salp,snowh,sncovr, & + xlai,shdfac,fvb,gama,fbur, & + fgsn,ztopv,zbotv,ua_phys) + + if ( ua_phys ) then + if(sfctmp <= t1) then + ru = 0. + else + ru = 100.*shdfac*fgsn*min((sfctmp-t1)/5., 1.) & + & *(1.-exp(-xlai)) + endif + ch = ch/(1.+ru*ch) + endif + + sncovr = min(sncovr,0.98) + + +!> - Call alcalc() to calculate surface albedo modification due to snowdepth +!! state. + call alcalc +! --- inputs: ! +! ( alb, snoalb, shdfac, shdmin, sncovr, tsnow, ! +! --- outputs: ! +! albedo ) ! + + endif ! end if_sneqv_block + + endif ! end if_ice_block + +! --- ... thermal conductivity for sea-ice case, glacial-ice case +!> - Calculate thermal diffusivity (\a df1): +!> - For sea-ice case and glacial-ice case, this is constant(\f$df1=2.2\f$). + + if (ice /= 0) then + + df1 = 2.2 + + else +!> - For non-glacial land case, call tdfcnd() to calculate the thermal +!! diffusivity of top soil layer (\cite peters-lidard_et_al_1998). + +! --- ... next calculate the subsurface heat flux, which first requires +! calculation of the thermal diffusivity. treatment of the +! latter follows that on pages 148-149 from "heat transfer in +! cold climates", by v. j. lunardini (published in 1981 +! by van nostrand reinhold co.) i.e. treatment of two contiguous +! "plane parallel" mediums (namely here the first soil layer +! and the snowpack layer, if any). this diffusivity treatment +! behaves well for both zero and nonzero snowpack, including the +! limit of very thin snowpack. this treatment also eliminates +! the need to impose an arbitrary upper bound on subsurface +! heat flux when the snowpack becomes extremely thin. + +! --- ... first calculate thermal diffusivity of top soil layer, using +! both the frozen and liquid soil moisture, following the +! soil thermal diffusivity function of peters-lidard et al. +! (1998,jas, vol 55, 1209-1224), which requires the specifying +! the quartz content of the given soil class (see routine redprm) + + call tdfcnd & +! --- inputs: + & ( smc(1), quartz, smcmax, sh2o(1), & +! --- outputs: + & df1 & + & ) +! if(ivegsrc == 1) then +!only igbp type has urban +!urban +! if ( vegtyp == 13 ) df1=3.24 +! endif + +!> - Add subsurface heat flux reduction effect from the +!! overlying green canopy, adapted from section 2.1.2 of +!! \cite peters-lidard_et_al_1997. +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) + else + df1 = df1 * exp( sbeta*shdfac ) + endif + + endif ! end if_ice_block + +! --- ... finally "plane parallel" snowpack effect following +! v.j. linardini reference cited above. note that dtot is +! combined depth of snowdepth and thickness of first soil layer + + dsoil = -0.5 * zsoil(1) + + if (sneqv == 0.0) then + + ssoil = df1 * (t1 - stc(1)) / dsoil + + else + + dtot = snowh + dsoil + frcsno = snowh / dtot + frcsoi = dsoil / dtot + +! --- ... 1. harmonic mean (series flow) + +! df1 = (sncond*df1) / (frcsoi*sncond + frcsno*df1) +! df1h = (sncond*df1) / (frcsoi*sncond + frcsno*df1) + +! --- ... 2. arithmetic mean (parallel flow) + +! df1 = frcsno*sncond + frcsoi*df1 + df1a = frcsno*sncond + frcsoi*df1 + +! --- ... 3. geometric mean (intermediate between harmonic and arithmetic mean) + +! df1 = (sncond**frcsno) * (df1**frcsoi) +! df1 = df1h*sncovr + df1a*(1.0-sncovr) +! df1 = df1h*sncovr + df1 *(1.0-sncovr) + df1 = df1a*sncovr + df1 *(1.0-sncovr) + +!> - Calculate subsurface heat flux, \a ssoil, from final thermal +!! diffusivity of surface mediums,\a df1 above, and skin +!! temperature and top mid-layer soil temperature. + + ssoil = df1 * (t1 - stc(1)) / dtot + + endif ! end if_sneqv_block + +!> - For uncoupled mode, call snowz0() to calculate surface roughness +!! (\a z0) over snowpack using snow condition from the previous timestep. + +! if (couple == 0) then ! uncoupled mode + if (sncovr > 0.0) then + + call snowz0 +! --- inputs: ! +! ( sncovr, ! +! --- input/outputs: ! +! z0 ) ! + + endif +! endif + +!> - Calculate virtual temps and virtual potential temps needed by +!! subroutines sfcdif and penman. + + t2v = sfctmp * (1.0 + 0.61*q2) + +! --- ... next call routine sfcdif to calculate the sfc exchange coef (ch) +! for heat and moisture. +! note - comment out call sfcdif, if sfcdif already called in calling +! program (such as in coupled atmospheric model). +! - do not call sfcdif until after above call to redprm, in case +! alternative values of roughness length (z0) and zilintinkevich +! coef (czil) are set there via namelist i/o. +! - routine sfcdif returns a ch that represents the wind spd times +! the "original" nondimensional "ch" typical in literature. hence +! the ch returned from sfcdif has units of m/s. the important +! companion coefficient of ch, carried here as "rch", is the ch +! from sfcdif times air density and parameter "cp". "rch" is +! computed in "call penman". rch rather than ch is the coeff +! usually invoked later in eqns. +! - sfcdif also returns the surface exchange coefficient for momentum, +! cm, also known as the surface drage coefficient, but cm is not +! used here. + +! --- ... key required radiation term is the total downward radiation +! (fdown) = net solar (swnet) + downward longwave (lwdn), +! for use in penman ep calculation (penman) and other surface +! energy budget calcuations. also need downward solar (swdn) +! for canopy resistance routine (canres). +! note - fdown, swdn are derived differently in the uncoupled and +! coupled modes. + +!> - Calculate the total downward radiation (\a fdown) = net solar (\a swnet) + +!! downward longwave (\a lwdn) as input of penman() and other surface +!! energy budget calculations. + + if (couple == 0) then !......uncoupled mode + +! --- ... uncoupled mode: +! compute surface exchange coefficients + + t1v = t1 * (1.0 + 0.61 * q2) + th2v = th2 * (1.0 + 0.61 * q2) + + call sfcdif +! --- inputs: ! +! ( zlvl, z0, t1v, th2v, sfcspd, czil, ! +! --- input/outputs: ! +! cm, ch ) ! + +! swnet = net solar radiation into the ground (w/m2; dn-up) from input +! fdown = net solar + downward lw flux at sfc (w/m2) + + fdown = swnet + lwdn + + else !......coupled mode + +! --- ... coupled mode (couple .ne. 0): +! surface exchange coefficients computed externally and passed in, +! hence subroutine sfcdif not called. + +! swnet = net solar radiation into the ground (w/m2; dn-up) from input +! fdown = net solar + downward lw flux at sfc (w/m2) + + fdown = swnet + lwdn + + endif ! end if_couple_block +! +! --- enhance cp as a function of z0 to mimic heat storage +! + cpx = cp + cpx1 = cp1 + cpfac = 1.0 + if (lheatstrg) then + if ((ivegsrc == 1 .and. vegtyp /= 13) + & .or. ivegsrc == 2) then + xx1 = (z0 - z0min) / (z0max - z0min) + xx2 = 1.0 + min(max(xx1, 0.0), 1.0) + cpx = cp * xx2 + cpx1 = cp1 * xx2 + cpfac = cp / cpx + endif + endif + +!> - Call penman() to calculate potential evaporation (\a etp), +!! and other partial products and sums for later +!! calculations. + + call penman +! --- inputs: ! +! ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, ! +! cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, ! +! --- outputs: ! +! t24, etp, rch, epsca, rr, flx2 ) ! + +!> - Call canres() to calculate the canopy resistance and convert it +!! into pc if nonzero greenness fraction. + + if (shdfac > 0.) then + +! --- ... frozen ground extension: total soil water "smc" was replaced +! by unfrozen soil water "sh2o" in call to canres below + + call canres +! --- inputs: ! +! ( nsoil, nroot, swdn, ch, q2, q2sat, dqsdt2, sfctmp, ! +! cpx1, sfcprs, sfcems, sh2o, smcwlt, smcref, zsoil, rsmin, ! +! rsmax, topt, rgl, hs, xlai, ! +! --- outputs: ! +! rc, pc, rcs, rct, rcq, rcsoil ) ! + + endif + +!> - Now decide major pathway branch to take depending on whether +!! snowpack exists or not: + + esnow = 0.0 + + if (sneqv .eq. 0.0) then +!> - For no snowpack is present, call nopac() to calculate soil moisture +!! and heat flux values and update soil moisture contant and soil heat +!! content values. + call nopac +! --- inputs: ! +! ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, ! +! smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, ! +! t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, ! +! slope, kdt, frzx, psisat, zsoil, dksat, dwsat, ! +! zbot, ice, rtdis, quartz, fxexp, csoil, ! +! --- input/outputs: ! +! cmc, t1, stc, sh2o, tbot, ! +! --- outputs: ! +! eta, smc, ssoil, runoff1, runoff2, runoff3, edir, ! +! ec, et, ett, beta, drip, dew, flx1, flx3 ) ! + + else + +!> - For a snowpack is present, call snopac(). + call snopac +! --- inputs: ! +! ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, ! +! cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, ! +! bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, ! +! zsoil, dwsat, dksat, zbot, shdfac, ice, rtdis, quartz, ! +! fxexp, csoil, flx2, snowng, ! +! --- input/outputs: ! +! prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, ! +! sh2o, tbot, beta, ! +! --- outputs: ! +! smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, ! +! ett, snomlt, drip, dew, flx1, flx3, esnow ) ! + + endif +!> - Noah LSM post-processing: +!> - Calculate sensible heat (h) for return to parent model. + + sheat = -(ch*cp1*sfcprs) / (rd1*t2v) * (th2 - t1) + +!> - Convert units and/or sign of total evap (eta), potential evap (etp), +!! subsurface heat flux (s), and runoffs for what parent model expects. +! convert eta from kg m-2 s-1 to w m-2 +! eta = eta * lsubc +! etp = etp * lsubc + + edir = edir * lsubc + ec = ec * lsubc + + do k = 1, 4 + et(k) = et(k) * lsubc + enddo + + ett = ett * lsubc + esnow = esnow * lsubs + etp = etp * ((1.0 - sncovr)*lsubc + sncovr*lsubs) + + if (etp > 0.) then + eta = edir + ec + ett + esnow + else + eta = etp + endif + + beta = eta / etp + +!> - Convert the sign of soil heat flux so that: +!! - ssoil>0: warm the surface (night time) +!! - ssoil<0: cool the surface (day time) + + ssoil = -1.0 * ssoil + + if (ice == 0) then + +!> - For the case of land (but not glacial-ice): +!! convert runoff3 (internal layer runoff from supersat) from \f$m\f$ +!! to \f$ms^-1\f$ and add to subsurface runoff/baseflow (runoff2). +!! runoff2 is already a rate at this point. + + runoff3 = runoff3 / dt + runoff2 = runoff2 + runoff3 + + else + +!> - For the case of sea-ice (ice=1) or glacial-ice (ice=-1), add any +!! snowmelt directly to surface runoff (runoff1) since there is no +!! soil medium, and thus no call to subroutine smflx (for soil +!! moisture tendency). + + runoff1 = snomlt / dt + endif + +!> - Calculate total column soil moisture in meters (soilm) and root-zone +!! soil moisture availability (fraction) relative to porosity/saturation. + + soilm = -1.0 * smc(1) * zsoil(1) + do k = 2, nsoil + soilm = soilm + smc(k)*(zsoil(k-1) - zsoil(k)) + enddo + + soilwm = -1.0 * (smcmax - smcwlt) * zsoil(1) + soilww = -1.0 * (smc(1) - smcwlt) * zsoil(1) + do k = 2, nroot + soilwm = soilwm + (smcmax - smcwlt) * (zsoil(k-1) - zsoil(k)) + soilww = soilww + (smc(k) - smcwlt) * (zsoil(k-1) - zsoil(k)) + enddo + + soilw = soilww / soilwm +! + return + + +! ================= + contains +! ================= + +!*************************************! +! section-1 1st level subprograms ! +!*************************************! + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates albedo including snow effect (0 -> 1). + subroutine alcalc (alb, snoalb, embrd, shdfac, shdmin, sncovr, & + & tsnow, albedo, sfcems, dt, snowng, snotime1, & + & lvcoef) +!................................... +! --- inputs: +! & ( alb, snoalb, shdfac, shdmin, sncovr, tsnow, & +! --- outputs: +! & albedo & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine alcalc calculates albedo including snow effect (0 -> 1) ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! alb - real, snowfree albedo 1 ! +! snoalb - real, maximum (deep) snow albedo 1 ! +! shdfac - real, areal fractional coverage of green veg. 1 ! +! shdmin - real, minimum areal coverage of green veg. 1 ! +! sncovr - real, fractional snow cover 1 ! +! tsnow - real, snow surface temperature (k) 1 ! +! ! +! outputs to calling program: ! +! albedo - real, surface albedo including snow effect 1 ! +! ! +! ==================== end of description ===================== ! +! + implicit none +! --- inputs: + real (kind=kind_phys), intent(in) :: alb, snoalb, embrd, shdfac, & + & shdmin, sncovr, tsnow, dt, lvcoef + + real (kind=kind_phys), intent(out) :: snotime1 + +! --- outputs: + real (kind=kind_phys), intent(out) :: albedo, sfcems + +! --- locals: + real (kind=kind_phys) :: snoalb1, snoalb2, tm + + real (kind=kind_phys), parameter :: snacca=0.94,snaccb=0.58, & + & snthwa=0.82,snthwb=0.46, & + & emissi_s=0.95 + +! +!===> ... begin here +! +!> --- ... snoalb is argument representing maximum albedo over deep snow, +! as passed into sflx, and adapted from the satellite-based +! maximum snow albedo fields provided by d. robinson and g. kukla +! (1985, jcam, vol 24, 402-411) + +! albedo = alb + (1.0-(shdfac-shdmin))*sncovr*(snoalb-alb) + albedo = alb + sncovr * (snoalb - alb) + emissi = embrd + sncovr * (emissi_s - embrd) + + +! --- base formulation (dickinson et al., 1986, cogley et al., 1990) +! if (tsnow.le.263.16) then +! albedo=snoalb +! else +! if (tsnow.lt.273.16) then +! tm=0.1*(tsnow-263.16) +! snoalb1=0.5*((0.9-0.2*(tm**3))+(0.8-0.16*(tm**3))) +! else +! snoalb1=0.67 +! if(sncovr.gt.0.95) snoalb1= 0.6 +! snoalb1 = alb + sncovr*(snoalb-alb) +! endif +! endif +! albedo = alb + sncovr*(snoalb1-alb) + +! isba formulation (verseghy, 1991; baker et al., 1990) +! snoalb1 = snoalb+coef*(0.85-snoalb) +! snoalb2=snoalb1 +!!m lstsnw=lstsnw+1 +! snotime1 = snotime1 + dt +! if (snowng) then +! snoalb2=snoalb +!!m lstsnw=0 +! snotime1 = 0.0 +! else +! if (tsnow.lt.273.16) then +!! snoalb2=snoalb-0.008*lstsnw*dt/86400 +!!m snoalb2=snoalb-0.008*snotime1/86400 +! snoalb2=(snoalb2-0.65)*exp(-0.05*dt/3600)+0.65 +!! snoalb2=(albedo-0.65)*exp(-0.01*dt/3600)+0.65 +! else +! snoalb2=(snoalb2-0.5)*exp(-0.0005*dt/3600)+0.5 +!! snoalb2=(snoalb-0.5)*exp(-0.24*lstsnw*dt/86400)+0.5 +!!m snoalb2=(snoalb-0.5)*exp(-0.24*snotime1/86400)+0.5 +! endif +! endif +! +!! print*,'snoalb2',snoalb2,'albedo',albedo,'dt',dt +! albedo = alb + sncovr*(snoalb2-alb) +! if (albedo .gt. snoalb2) albedo=snoalb2 +!!m lstsnw1=lstsnw +!! snotime = snotime1 + +!> formulation by livneh +! ---------------------------------------------------------------------- +! snoalb is considered as the maximum snow albedo for new snow, at +! a value of 85%. snow albedo curve defaults are from bras p.263. should +! not be changed except for serious problems with snow melt. +! to implement accumulatin parameters, snacca and snaccb, assert that it +! is indeed accumulation season. i.e. that snow surface temp is below +! zero and the date falls between october and february +! ---------------------------------------------------------------------- + snoalb1 = snoalb+lvcoef*(0.85-snoalb) + snoalb2=snoalb1 +! ---------------- initial lstsnw -------------------------------------- + if (snowng) then + snotime1 = 0. + else + snotime1=snotime1+dt +! if (tsnow.lt.273.16) then + snoalb2=snoalb1*(snacca**((snotime1/86400.0)**snaccb)) +! else +! snoalb2 +! =snoalb1*(snthwa**((snotime1/86400.0)**snthwb)) +! endif + endif +! + snoalb2 = max ( snoalb2, alb ) + albedo = alb + sncovr*(snoalb2-alb) + if (albedo .gt. snoalb2) albedo=snoalb2 + +! if (tsnow.lt.273.16) then +! albedo=snoalb-0.008*dt/86400 +! else +! albedo=(snoalb-0.5)*exp(-0.24*dt/86400)+0.5 +! endif + +! if (albedo > snoalb) albedo = snoalb + +! + return +!................................... + end subroutine alcalc +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates canopy resistance which depends on incoming +!! solar radiation, air temperature, atmospheric water vapor pressure +!! deficit at the lowest model level, and soil moisture (preferably unfrozen +!! soil moisture rather than total). + subroutine canres (swdn,ch,sfctmp,q2,sfcprs,smc,zsoil,nsoil, & + smcwlt,smcref,rsmin,rc,pc,nroot,q2sat,dqsdt2, & + topt,rsmax,rgl,hs,xlai, & + rcs,rct,rcq,rcsoil,emissi) + +! --- inputs: +! & ( nsoil, nroot, swdn, ch, q2, q2sat, dqsdt2, sfctmp, & +! & cpx1, sfcprs, sfcems, sh2o, smcwlt, smcref, zsoil, rsmin, & +! & rsmax, topt, rgl, hs, xlai, & +! --- outputs: +! & rc, pc, rcs, rct, rcq, rcsoil & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine canres calculates canopy resistance which depends on ! +! incoming solar radiation, air temperature, atmospheric water vapor ! +! pressure deficit at the lowest model level, and soil moisture ! +! (preferably unfrozen soil moisture rather than total) ! +! ! +! source: jarvis (1976), noilhan and planton (1989, mwr), jacquemin ! +! and noilhan (1990, blm) ! +! see also: chen et al (1996, jgr, vol 101(d3), 7251-7268), eqns ! +! 12-14 and table 2 of sec. 3.1.2 ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, no. of soil layers 1 ! +! nroot - integer, no. of soil layers in root zone ( ... begin here +! +! --- ... initialize canopy resistance multiplier terms. + + rcs = 0.0 + rct = 0.0 + rcq = 0.0 + rcsoil = 0.0 + rc = 0.0 + +! --- ... contribution due to incoming solar radiation + + ff = 0.55 * 2.0 * swdn / (rgl*xlai) + rcs = (ff + rsmin/rsmax) / (1.0 + ff) + rcs = max( rcs, 0.0001 ) + +! --- ... contribution due to air temperature at first model level above ground +! rct expression from noilhan and planton (1989, mwr). + + rct = 1.0 - 0.0016 * (topt - sfctmp)**2.0 + rct = max( rct, 0.0001 ) + +! --- ... contribution due to vapor pressure deficit at first model level. +! rcq expression from ssib + + rcq = 1.0 / (1.0 + hs*(q2sat-q2)) + rcq = max( rcq, 0.01 ) + +! --- ... contribution due to soil moisture availability. +! determine contribution from each soil layer, then add them up. + + gx = (sh2o(1) - smcwlt) / (smcref - smcwlt) + gx = max( 0.0, min( 1.0, gx ) ) + +! --- ... use soil depth as weighting factor + part(1) = (zsoil(1)/zsoil(nroot)) * gx + +! --- ... use root distribution as weighting factor +! part(1) = rtdis(1) * gx + + do k = 2, nroot + + gx = (sh2o(k) - smcwlt) / (smcref - smcwlt) + gx = max( 0.0, min( 1.0, gx ) ) + +! --- ... use soil depth as weighting factor + part(k) = ((zsoil(k) - zsoil(k-1)) / zsoil(nroot)) * gx + +! --- ... use root distribution as weighting factor +! part(k) = rtdis(k) * gx + + enddo + + do k = 1, nroot + rcsoil = rcsoil + part(k) + enddo + rcsoil = max( rcsoil, 0.0001 ) + +! --- ... determine canopy resistance due to all factors. convert canopy +! resistance (rc) to plant coefficient (pc) to be used with +! potential evap in determining actual evap. pc is determined by: +! pc * linerized penman potential evap = penman-monteith actual +! evaporation (containing rc term). + + rc = rsmin / (xlai*rcs*rct*rcq*rcsoil) + rr = (4.0*sfcems*sigma1*rd1/cpx1) * (sfctmp**4.0)/(sfcprs*ch) + 1.0 + delta = (lsubc/cpx1) * dqsdt2 + + pc = (rr + delta) / (rr*(1.0 + rc*ch) + delta) +! + return +!................................... + end subroutine canres +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates snow termal conductivity + subroutine csnow (sndens, sncond) +!................................... +! --- inputs: +! & ( sndens, & +! --- outputs: +! & sncond & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine csnow calculates snow termal conductivity ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sndens - real, snow density 1 ! +! ! +! outputs to the calling program: ! +! sncond - real, snow termal conductivity 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + real (kind=kind_phys), parameter :: unit = 0.11631 + +! --- inputs: + real (kind=kind_phys), intent(in) :: sndens + +! --- outputs: + real (kind=kind_phys), intent(out) :: sncond + +! --- locals: + real (kind=kind_phys) :: c + +! +!===> ... begin here +! +! --- ... sncond in units of cal/(cm*hr*c), returned in w/(m*c) +! basic version is dyachkova equation (1960), for range 0.1-0.4 + + c = 0.328 * 10**(2.25*sndens) + sncond = 2.0 * unit * c + +! --- ... de vaux equation (1933), in range 0.1-0.6 + +! sncond = 0.0293 * (1.0 + 100.0*sndens**2) + +! --- ... e. andersen from flerchinger + +! sncond = 0.021 + 2.51 * sndens**2 +! + return +!................................... + end subroutine csnow +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates soil moisture and heat flux values and +!! update soil moisture content and soil heat content values for the +!! case when no snow pack is present. + subroutine nopac +!................................... +! --- inputs: +! & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, & +! & smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, & +! & t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, & +! & slope, kdt, frzx, psisat, zsoil, dksat, dwsat, & +! & zbot, ice, rtdis, quartz, fxexp, csoil, & +! --- input/outputs: +! & cmc, t1, stc, sh2o, tbot, & +! --- outputs: +! & eta, smc, ssoil, runoff1, runoff2, runoff3, edir, & +! & ec, et, ett, beta, drip, dew, flx1, flx3 & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine nopac calculates soil moisture and heat flux values and ! +! update soil moisture content and soil heat content values for the ! +! case when no snow pack is present. ! +! ! +! ! +! subprograms called: evapo, smflx, tdfcnd, shflx ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! etp - real, potential evaporation 1 ! +! prcp - real, precip rate 1 ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! dt - real, time step 1 ! +! shdfac - real, aeral coverage of green veg 1 ! +! sbeta - real, param to cal veg effect on soil heat flux 1 ! +! sfctmp - real, air temp at height zlvl abv ground 1 ! +! sfcems - real, sfc lw emissivity 1 ! +! t24 - real, sfctmp**4 1 ! +! th2 - real, air potential temp at zlvl abv grnd 1 ! +! fdown - real, net solar + downward lw flux at sfc 1 ! +! epsca - real, 1 ! +! bexp - real, soil type "b" parameter 1 ! +! pc - real, plant coeff 1 ! +! rch - real, companion coefficient of ch 1 ! +! rr - real, 1 ! +! cfactr - real, canopy water parameters 1 ! +! slope - real, linear reservoir coefficient 1 ! +! kdt - real, 1 ! +! frzx - real, frozen ground parameter 1 ! +! psisat - real, saturated soil potential 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! zbot - real, specify depth of lower bd soil 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! rtdis - real, root distribution nsoil ! +! quartz - real, soil quartz content 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! csoil - real, soil heat capacity 1 ! +! ! +! input/outputs from and to the calling program: ! +! cmc - real, canopy moisture content 1 ! +! t1 - real, ground/canopy/snowpack eff skin temp 1 ! +! stc - real, soil temp nsoil ! +! sh2o - real, unfrozen soil moisture nsoil ! +! tbot - real, bottom soil temp 1 ! +! ! +! outputs to the calling program: ! +! eta - real, downward latent heat flux 1 ! +! smc - real, total soil moisture nsoil ! +! ssoil - real, upward soil heat flux 1 ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff (baseflow) 1 ! +! runoff3 - real, excess of porosity 1 ! +! edir - real, direct soil evaporation 1 ! +! ec - real, canopy water evaporation 1 ! +! et - real, plant transpiration nsoil ! +! ett - real, total plant transpiration 1 ! +! beta - real, ratio of actual/potential evap 1 ! +! drip - real, through-fall of precip and/or dew 1 ! +! dew - real, dewfall (or frostfall) 1 ! +! flx1 - real, precip-snow sfc flux 1 ! +! flx3 - real, phase-change heat flux from snowmelt 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! integer, intent(in) :: nsoil, nroot, ice + +! real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, & +! & smcwlt, smcref, smcdry, cmcmax, dt, shdfac, sbeta, & +! & sfctmp, sfcems, t24, th2, fdown, epsca, bexp, pc, & +! & rch, rr, cfactr, slope, kdt, frzx, psisat, & +! & zsoil(nsoil), dksat, dwsat, zbot, rtdis(nsoil), & +! & quartz, fxexp, csoil + +! --- input/outputs: +! real (kind=kind_phys), intent(inout) :: cmc, t1, stc(nsoil), & +! & sh2o(nsoil), tbot + +! --- outputs: +! real (kind=kind_phys), intent(out) :: eta, smc(nsoil), ssoil, & +! & runoff1, runoff2, runoff3, edir, ec, et(nsoil), ett, & +! & beta, drip, dew, flx1, flx3 + +! --- locals: + real (kind=kind_phys) :: df1, eta1, etp1, prcp1, yy, yynum, & + & zz1, ec1, edir1, et1(nsoil), ett1 + + integer :: k + +! +!===> ... begin here +! +! --- ... convert etp from kg m-2 s-1 to ms-1 and initialize dew. + + prcp1= prcp * 0.001 + etp1 = etp * 0.001 + dew = 0.0 + edir = 0.0 + edir1= 0.0 + ec = 0.0 + ec1 = 0.0 + + do k = 1, nsoil + et (k) = 0.0 + et1(k) = 0.0 + enddo + + ett = 0.0 + ett1 = 0.0 + + if (etp > 0.0) then + +! --- ... convert prcp from 'kg m-2 s-1' to 'm s-1'. + + call evapo & +! --- inputs: + & ( nsoil, nroot, cmc, cmcmax, etp1, dt, zsoil, & + & sh2o, smcmax, smcwlt, smcref, smcdry, pc, & + & shdfac, cfactr, rtdis, fxexp, & +! --- outputs: + & eta1, edir1, ec1, et1, ett1 & + & ) + + call smflx & +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + + else + +! --- ... if etp < 0, assume dew forms (transform etp1 into dew and +! reinitialize etp1 to zero). + + eta1 = 0.0 + dew = -etp1 + +! --- ... convert prcp from 'kg m-2 s-1' to 'm s-1' and add dew amount. + + prcp1 = prcp1 + dew + + call smflx & +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + + endif ! end if_etp_block + +! --- ... convert modeled evapotranspiration fm m s-1 to kg m-2 s-1 + + eta = eta1 * 1000.0 + edir = edir1 * 1000.0 + ec = ec1 * 1000.0 + + do k = 1, nsoil + et(k) = et1(k) * 1000.0 + enddo + + ett = ett1 * 1000.0 + +! --- ... based on etp and e values, determine beta + + if ( etp <= 0.0 ) then + beta = 0.0 + if ( etp < 0.0 ) then + beta = 1.0 + endif + else + beta = eta / etp + endif + +! --- ... get soil thermal diffuxivity/conductivity for top soil lyr, +! calc. adjusted top lyr soil temp and adjusted soil flux, then +! call shflx to compute/update soil heat flux and soil temps. + + call tdfcnd & +! --- inputs: + & ( smc(1), quartz, smcmax, sh2o(1), & +! --- outputs: + & df1 & + & ) +! if(ivegsrc == 1) then +!urban +! if ( vegtyp == 13 ) df1=3.24 +! endif + +! --- ... vegetation greenness fraction reduction in subsurface heat +! flux via reduction factor, which is convenient to apply here +! to thermal diffusivity that is later used in hrt to compute +! sub sfc heat flux (see additional comments on veg effect +! sub-sfc heat flx in routine sflx) +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) + else + df1 = df1 * exp( sbeta*shdfac ) + endif + +! --- ... compute intermediate terms passed to routine hrt (via routine +! shflx below) for use in computing subsurface heat flux in hrt + + yynum = fdown - sfcems*sigma1*t24 + yy = sfctmp + (yynum/rch + th2 - sfctmp - beta*epsca)/rr + zz1 = df1/(-0.5*zsoil(1)*rch*rr) + 1.0 + + call shflx & +! --- inputs: + & ( nsoil, smc, smcmax, dt, yy, zz1, zsoil, zbot, & + & psisat, bexp, df1, ice, quartz, csoil, vegtyp, & +! --- input/outputs: + & stc, t1, tbot, sh2o, & +! --- outputs: + & ssoil & + & ) + +! --- ... set flx1 and flx3 (snopack phase change heat fluxes) to zero since +! they are not used here in snopac. flx2 (freezing rain heat flux) +! was similarly initialized in the penman routine. + + flx1 = 0.0 + flx3 = 0.0 +! + return +!................................... + end subroutine nopac +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates potential evaporation for the current point. +!! various partial sums/products are also calculated and passed back +!! to the calling routine for later use + subroutine penman +!................................... +! --- inputs: +! & ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, & +! & cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, & +! --- outputs: +! & t24, etp, rch, epsca, rr, flx2 & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine penman calculates potential evaporation for the current ! +! point. various partial sums/products are also calculated and passed ! +! back to the calling routine for later use. ! +! ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! sfctmp - real, sfc temperature at 1st level above ground 1 ! +! sfcprs - real, sfc pressure 1 ! +! sfcems - real, sfc emissivity for lw radiation 1 ! +! ch - real, sfc exchange coeff for heat & moisture 1 ! +! t2v - real, sfc virtual temperature 1 ! +! th2 - real, air potential temp at zlvl abv grnd 1 ! +! prcp - real, precip rate 1 ! +! fdown - real, net solar + downward lw flux at sfc 1 ! +! cpx - real, enhanced air heat capacity for heat storage 1 ! +! cpfac - real, ratio air heat capacity to enhanced one 1 ! +! ssoil - real, upward soil heat flux 1 ! +! q2 - real, mixing ratio at hght zlvl abv ground 1 ! +! q2sat - real, sat mixing ratio at zlvl abv ground 1 ! +! dqsdt2 - real, slope of sat specific humidity curve 1 ! +! snowng - logical, snow flag 1 ! +! frzgra - logical, freezing rain flag 1 ! +! ! +! outputs: ! +! t24 - real, sfctmp**4 1 ! +! etp - real, potential evaporation 1 ! +! rch - real, companion coefficient of ch 1 ! +! epsca - real, 1 ! +! rr - real, 1 ! +! flx2 - real, freezing rain latent heat flux 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real (kind=kind_phys), intent(in) :: sfctmp, sfcprs, sfcems, & +! & ch, t2v, th2, prcp, fdown, ssoil, q2, q2sat, dqsdt2 + +! logical, intent(in) :: snowng, frzgra + +! --- outputs: +! real (kind=kind_phys), intent(out) :: t24, etp, rch, epsca, & +! & rr, flx2 + +! --- locals: + real (kind=kind_phys) :: a, delta, fnet, rad, rho + +! +!===> ... begin here +! + flx2 = 0.0 + +! --- ... prepare partial quantities for penman equation. + +!MKB delta = elcp * cpfac * dqsdt2 +!MKB in hwrf + delta = elcp * dqsdt2 + t24 = sfctmp * sfctmp * sfctmp * sfctmp +!MKB rr = t24 * 6.48e-8 / (sfcprs*ch) + 1.0 +!MKB rr in hwrf (sfcems is emissi in hwrf) + rr = sfcems * t24 * 6.48e-8 / (sfcprs*ch) + 1.0 + rho = sfcprs / (rd1*t2v) + rch = rho * cpx * ch + +! --- ... adjust the partial sums / products with the latent heat +! effects caused by falling precipitation. + + if (.not. snowng) then + if (prcp > 0.0) rr = rr + cph2o1*prcp/rch + else +! ---- ... fractional snowfall/rainfall +!MKB rr = rr + (cpice*ffrozp+cph2o1*(1.-ffrozp)) & +!MKB in hwrf + rr = rr + cpice & + & *prcp/rch + endif + + fnet = fdown - sfcems*sigma1*t24 - ssoil + +! --- ... include the latent heat effects of frzng rain converting to ice +! on impact in the calculation of flx2 and fnet. + + if (frzgra) then + flx2 = -lsubf * prcp + fnet = fnet - flx2 + endif + +! --- ... finish penman equation calculations. + + rad = fnet/rch + th2 - sfctmp + a = elcp * cpfac * (q2sat - q2) + epsca = (a*rr + rad*delta) / (delta + rr) +!MKB for hwrf +! Fei-Mike + if (epsca > 0.) epsca = epsca * aoasis + etp = epsca * rch /lvs +!MKB etp = epsca * rch / lsubc + + if (ua_phys) then + radn = fnetn / rch + th2 - sfctmp + epscan = (a * rr + radn * delta) / (delta + rr) + etpn = epscan * rch / lvs + endif +! + return +!................................... + end subroutine penman +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine internally sets default values or optionally read-in +!! via namelist i/o, all soil and vegetation parateters requied for the execusion +!! of the Noah LSM. + subroutine redprm +!................................... +! --- inputs: +! & ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, & +! --- outputs: +! & cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, & +! & sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, & +! & snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, & +! & smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, & +! & z0, czil, xlai, csoil & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine redprm internally sets(default valuess), or optionally ! +! read-in via namelist i/o, all soil and vegetation parameters ! +! required for the execusion of the noah lsm. ! +! ! +! optional non-default parameters can be read in, accommodating up to ! +! 30 soil, veg, or slope classes, if the default max number of soil, ! +! veg, and/or slope types is reset. ! +! ! +! future upgrades of routine redprm must expand to incorporate some ! +! of the empirical parameters of the frozen soil and snowpack physics ! +! (such as in routines frh2o, snowpack, and snow_new) not yet set in ! +! this redprm routine, but rather set in lower level subroutines. ! +! ! +! all soil, veg, slope, and universal parameters values are defined ! +! externally (in subroutine "set_soilveg.f") and then accessed via ! +! "use namelist_soilveg" (below) and then set here. ! +! ! +! soil types zobler (1986) cosby et al (1984) (quartz cont.(1)) ! +! 1 coarse loamy sand (0.82) ! +! 2 medium silty clay loam (0.10) ! +! 3 fine light clay (0.25) ! +! 4 coarse-medium sandy loam (0.60) ! +! 5 coarse-fine sandy clay (0.52) ! +! 6 medium-fine clay loam (0.35) ! +! 7 coarse-med-fine sandy clay loam (0.60) ! +! 8 organic loam (0.40) ! +! 9 glacial land ice loamy sand (na using 0.82)! +! 13: - glacial land ice - ! +! 13: glacial-ice (no longer use these parameters), now ! +! treated as ice-only surface and sub-surface ! +! (in subroutine hrtice) ! +! upgraded to statsgo (19-type) +! 1: sand +! 2: loamy sand +! 3: sandy loam +! 4: silt loam +! 5: silt +! 6:loam +! 7:sandy clay loam +! 8:silty clay loam +! 9:clay loam +! 10:sandy clay +! 11: silty clay +! 12: clay +! 13: organic material +! 14: water +! 15: bedrock +! 16: other (land-ice) +! 17: playa +! 18: lava +! 19: white sand +! ! +! ssib vegetation types (dorman and sellers, 1989; jam) ! +! 1: broadleaf-evergreen trees (tropical forest) ! +! 2: broadleaf-deciduous trees ! +! 3: broadleaf and needleleaf trees (mixed forest) ! +! 4: needleleaf-evergreen trees ! +! 5: needleleaf-deciduous trees (larch) ! +! 6: broadleaf trees with groundcover (savanna) ! +! 7: groundcover only (perennial) ! +! 8: broadleaf shrubs with perennial groundcover ! +! 9: broadleaf shrubs with bare soil ! +! 10: dwarf trees and shrubs with groundcover (tundra) ! +! 11: bare soil ! +! 12: cultivations (the same parameters as for type 7) ! +! 13: - glacial (the same parameters as for type 11) - ! +! 13: glacial-ice (no longer use these parameters), now treated as ! +! ice-only surface and sub-surface (in subroutine hrtice) ! +! upgraded to IGBP (20-type) +! 1:Evergreen Needleleaf Forest +! 2:Evergreen Broadleaf Forest +! 3:Deciduous Needleleaf Forest +! 4:Deciduous Broadleaf Forest +! 5:Mixed Forests +! 6:Closed Shrublands +! 7:Open Shrublands +! 8:Woody Savannas +! 9:Savannas +! 10:Grasslands +! 11:Permanent wetlands +! 12:Croplands +! 13:Urban and Built-Up +! 14:Cropland/natural vegetation mosaic +! 15:Snow and Ice +! 16:Barren or Sparsely Vegetated +! 17:Water +! 18:Wooded Tundra +! 19:Mixed Tundra +! 20:Bare Ground Tundra +! ! +! slopetyp is to estimate linear reservoir coefficient slope to the ! +! baseflow runoff out of the bottom layer. lowest class (slopetyp=0) ! +! means highest slope parameter = 1. ! +! ! +! slope class percent slope ! +! 1 0-8 ! +! 2 8-30 ! +! 3 > 30 ! +! 4 0-30 ! +! 5 0-8 & > 30 ! +! 6 8-30 & > 30 ! +! 7 0-8, 8-30, > 30 ! +! 9 glacial ice ! +! blank ocean/sea ! +! ! +! note: class 9 from zobler file should be replaced by 8 and 'blank' 9 ! +! ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! vegtyp - integer, vegetation type (integer index) 1 ! +! soiltyp - integer, soil type (integer index) 1 ! +! slopetyp - integer, class of sfc slope (integer index) 1 ! +! sldpth - integer, thickness of each soil layer (m) nsoil ! +! zsoil - integer, soil depth (negative sign) (m) nsoil ! +! ! +! outputs to the calling program: ! +! cfactr - real, canopy water parameters 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! rsmin - real, mimimum stomatal resistance 1 ! +! rsmax - real, maximum stomatal resistance 1 ! +! topt - real, optimum transpiration air temperature 1 ! +! refkdt - real, =2.e-6 the sat. dk. val for soil type 2 1 ! +! kdt - real, 1 ! +! sbeta - real, param to cal veg effect on soil heat flux 1 ! +! shdfac - real, vegetation greenness fraction 1 ! +! rgl - real, canopy resistance func (in solar rad term) 1 ! +! hs - real, canopy resistance func (vapor deficit term) 1 ! +! zbot - real, specify depth of lower bd soil temp (m) 1 ! +! frzx - real, frozen ground parameter, ice content 1 ! +! threshold above which frozen soil is impermeable ! +! psisat - real, saturated soil potential 1 ! +! slope - real, linear reservoir coefficient 1 ! +! snup - real, threshold snow depth (water equi m) 1 ! +! salp - real, snow cover shape parameter 1 ! +! from anderson's hydro-17 best fit salp = 2.6 ! +! bexp - real, the 'b' parameter 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! smcmax - real, max soil moisture content (porosity) 1 ! +! smcwlt - real, wilting pt soil moisture contents 1 ! +! smcref - real, reference soil moisture (onset stress) 1 ! +! smcdry - real, air dry soil moist content limits 1 ! +! f1 - real, used to comp soil diffusivity/conductivity 1 ! +! quartz - real, soil quartz content 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! rtdis - real, root distribution nsoil ! +! nroot - integer, number of root layers 1 ! +! z0 - real, roughness length (m) 1 ! +! czil - real, param to cal roughness length of heat 1 ! +! xlai - real, leaf area index 1 ! +! csoil - real, soil heat capacity (j m-3 k-1) 1 ! +! ! +! ==================== end of description ===================== ! +! + use namelist_soilveg + +! --- input: +! integer, intent(in) :: nsoil, vegtyp, soiltyp, slopetyp + +! real (kind=kind_phys), intent(in) :: sldpth(nsoil), zsoil(nsoil) + +! --- outputs: +! real (kind=kind_phys), intent(out) :: cfactr, cmcmax, rsmin, & +! & rsmax, topt, refkdt, kdt, sbeta, shdfac, rgl, hs, zbot, & +! & frzx, psisat, slope, snup, salp, bexp, dksat, dwsat, & +! & smcmax, smcwlt, smcref, smcdry, f1, quartz, fxexp, z0, & +! & czil, xlai, csoil, rtdis(nsoil) + +! integer, intent(out) :: nroot + +! --- locals: + real (kind=kind_phys) :: frzfact, frzk, refdk + + integer :: i + +! +!===> ... begin here +! + if (soiltyp > defined_soil) then + write(*,*) 'warning: too many soil types,soiltyp=',soiltyp, & + & 'defined_soil=',defined_soil + stop 333 + endif + + if (vegtyp > defined_veg) then + write(*,*) 'warning: too many veg types' + stop 333 + endif + + if (slopetyp > defined_slope) then + write(*,*) 'warning: too many slope types' + stop 333 + endif + +! --- ... set-up universal parameters (not dependent on soiltyp, vegtyp +! or slopetyp) + + zbot = zbot_data + salp = salp_data + cfactr = cfactr_data + cmcmax = cmcmax_data + sbeta = sbeta_data + rsmax = rsmax_data + topt = topt_data + refdk = refdk_data + frzk = frzk_data + fxexp = fxexp_data + refkdt = refkdt_data + czil = czil_data + csoil = csoil_data + +! --- ... set-up soil parameters + + bexp = bb (soiltyp) + dksat = satdk(soiltyp) + dwsat = satdw(soiltyp) + f1 = f11 (soiltyp) + kdt = refkdt * dksat / refdk + + psisat = satpsi(soiltyp) + quartz = qtz (soiltyp) + smcdry = drysmc(soiltyp) + smcmax = maxsmc(soiltyp) + smcref = refsmc(soiltyp) + smcwlt = wltsmc(soiltyp) + + frzfact = (smcmax / smcref) * (0.412 / 0.468) + +! --- ... to adjust frzk parameter to actual soil type: frzk * frzfact + + frzx = frzk * frzfact + +! --- ... set-up vegetation parameters + + nroot = nroot_data(vegtyp) + snup = snupx(vegtyp) + rsmin = rsmtbl(vegtyp) + + rgl = rgltbl(vegtyp) + hs = hstbl(vegtyp) +! roughness lengthe is defined in sfcsub +! z0 = z0_data(vegtyp) + xlai= lai_data(vegtyp) + + if (vegtyp == bare) shdfac = 0.0 + + if (nroot > nsoil) then + write(*,*) 'warning: too many root layers' + stop 333 + endif + +! --- ... calculate root distribution. present version assumes uniform +! distribution based on soil layer depths. + + do i = 1, nroot + rtdis(i) = -sldpth(i) / zsoil(nroot) + enddo + +! --- ... set-up slope parameter + + slope = slope_data(slopetyp) +! + return +!................................... + end subroutine redprm +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates surface layer exchange coefficients +!! via iterative process(see Chen et al.(1997) \cite chen_et_al_1997). + subroutine sfcdif +!................................... +! --- inputs: +! & ( zlvl, z0, t1v, th2v, sfcspd, czil, & +! --- input/outputs: +! & cm, ch & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine sfcdif calculates surface layer exchange coefficients ! +! via iterative process. see chen et al (1997, blm) ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! zlvl - real, height abv atmos ground forcing vars (m) 1 ! +! z0 - real, roughness length (m) 1 ! +! t1v - real, surface exchange coefficient 1 ! +! th2v - real, surface exchange coefficient 1 ! +! sfcspd - real, wind speed at height zlvl abv ground (m/s) 1 ! +! czil - real, param to cal roughness length of heat 1 ! +! ! +! input/outputs from and to the calling program: ! +! cm - real, sfc exchange coeff for momentum (m/s) 1 ! +! ch - real, sfc exchange coeff for heat & moisture (m/s)1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + integer, parameter :: itrmx = 5 + real (kind=kind_phys), parameter :: wwst = 1.2 + real (kind=kind_phys), parameter :: wwst2 = wwst*wwst + real (kind=kind_phys), parameter :: vkrm = 0.40 + real (kind=kind_phys), parameter :: excm = 0.001 + real (kind=kind_phys), parameter :: beta = 1.0/270.0 + real (kind=kind_phys), parameter :: btg = beta*gs1 + real (kind=kind_phys), parameter :: elfc = vkrm*btg + real (kind=kind_phys), parameter :: wold = 0.15 + real (kind=kind_phys), parameter :: wnew = 1.0-wold + real (kind=kind_phys), parameter :: pihf = 3.14159265/2.0 ! con_pi/2.0 + + real (kind=kind_phys), parameter :: epsu2 = 1.e-4 + real (kind=kind_phys), parameter :: epsust = 0.07 + real (kind=kind_phys), parameter :: ztmin = -5.0 + real (kind=kind_phys), parameter :: ztmax = 1.0 + real (kind=kind_phys), parameter :: hpbl = 1000.0 + real (kind=kind_phys), parameter :: sqvisc = 258.2 + + real (kind=kind_phys), parameter :: ric = 0.183 + real (kind=kind_phys), parameter :: rric = 1.0/ric + real (kind=kind_phys), parameter :: fhneu = 0.8 + real (kind=kind_phys), parameter :: rfc = 0.191 + real (kind=kind_phys), parameter :: rfac = ric/(fhneu*rfc*rfc) + +! --- inputs: +! real (kind=kind_phys), intent(in) :: zlvl, z0, t1v, th2v, & +! & sfcspd, czil + +! --- input/outputs: +! real (kind=kind_phys), intent(inout) :: cm, ch + +! --- locals: + real (kind=kind_phys) :: zilfc, zu, zt, rdz, cxch, dthv, du2, & + & btgh, wstar2, ustar, zslu, zslt, rlogu, rlogt, rlmo, & + & zetalt, zetalu, zetau, zetat, xlu4, xlt4, xu4, xt4, & + & xlu, xlt, xu, xt, psmz, simm, pshz, simh, ustark, & + & rlmn, rlma + + integer :: ilech, itr + +! --- define local in-line functions: + + real (kind=kind_phys) :: pslmu, pslms, pslhu, pslhs, zz + real (kind=kind_phys) :: pspmu, pspms, psphu, psphs, xx, yy + +! ... 1) lech's surface functions + + pslmu( zz ) = -0.96 * log( 1.0-4.5*zz ) + pslms( zz ) = zz*rric - 2.076*(1.0 - 1.0/(zz + 1.0)) + pslhu( zz ) = -0.96 * log( 1.0-4.5*zz ) + pslhs( zz ) = zz*rfac - 2.076*(1.0 - 1.0/(zz + 1.0)) + +! ... 2) paulson's surface functions + + pspmu( xx ) = -2.0 * log( (xx + 1.0)*0.5 ) & + & - log( (xx*xx + 1.0)*0.5 ) + 2.0*atan(xx) - pihf + pspms( yy ) = 5.0 * yy + psphu( xx ) = -2.0 * log( (xx*xx + 1.0)*0.5 ) + psphs( yy ) = 5.0 * yy + +! +!===> ... begin here +! +! --- ... this routine sfcdif can handle both over open water (sea, ocean) and +! over solid surface (land, sea-ice). + + ilech = 0 + +! --- ... ztfc: ratio of zoh/zom less or equal than 1 +! czil: constant c in zilitinkevich, s. s.1995,:note about zt + + zilfc = -czil * vkrm * sqvisc + + zu = z0 + + rdz = 1.0 / zlvl + cxch = excm * rdz + dthv = th2v - t1v + du2 = max( sfcspd*sfcspd, epsu2 ) + +! --- ... beljars correction of ustar + + btgh = btg * hpbl + +! --- ... if statements to avoid tangent linear problems near zero + if (btgh*ch*dthv /= 0.0) then + wstar2 = wwst2 * abs( btgh*ch*dthv )**(2.0/3.0) + else + wstar2 = 0.0 + endif + + ustar = max( sqrt( cm*sqrt( du2+wstar2 ) ), epsust ) + +! --- ... zilitinkevitch approach for zt + + zt = exp( zilfc*sqrt( ustar*z0 ) ) * z0 + + zslu = zlvl + zu + zslt = zlvl + zt + +! print*,'zslt=',zslt +! print*,'zlvl=',zvll +! print*,'zt=',zt + + rlogu = log( zslu/zu ) + rlogt = log( zslt/zt ) + + rlmo = elfc*ch*dthv / ustar**3 + +! print*,'rlmo=',rlmo +! print*,'elfc=',elfc +! print*,'ch=',ch +! print*,'dthv=',dthv +! print*,'ustar=',ustar + + do itr = 1, itrmx + +! --- ... 1./ monin-obukkhov length-scale + + zetalt = max( zslt*rlmo, ztmin ) + rlmo = zetalt / zslt + zetalu = zslu * rlmo + zetau = zu * rlmo + zetat = zt * rlmo + + if (ilech == 0) then + + if (rlmo < 0.0) then + xlu4 = 1.0 - 16.0 * zetalu + xlt4 = 1.0 - 16.0 * zetalt + xu4 = 1.0 - 16.0 * zetau + xt4 = 1.0 - 16.0* zetat + + xlu = sqrt( sqrt( xlu4 ) ) + xlt = sqrt( sqrt( xlt4 ) ) + xu = sqrt( sqrt( xu4 ) ) + xt = sqrt( sqrt( xt4 ) ) + + psmz = pspmu(xu) + +! print*,'-----------1------------' +! print*,'psmz=',psmz +! print*,'pspmu(zetau)=',pspmu( zetau ) +! print*,'xu=',xu +! print*,'------------------------' + + simm = pspmu( xlu ) - psmz + rlogu + pshz = psphu( xt ) + simh = psphu( xlt ) - pshz + rlogt + else + zetalu = min( zetalu, ztmax ) + zetalt = min( zetalt, ztmax ) + psmz = pspms( zetau ) + +! print*,'-----------2------------' +! print*,'psmz=',psmz +! print*,'pspms(zetau)=',pspms( zetau ) +! print*,'zetau=',zetau +! print*,'------------------------' + + simm = pspms( zetalu ) - psmz + rlogu + pshz = psphs( zetat ) + simh = psphs( zetalt ) - pshz + rlogt + endif ! end if_rlmo_block + + else + +! --- ... lech's functions + + if (rlmo < 0.0) then + psmz = pslmu( zetau ) + +! print*,'-----------3------------' +! print*,'psmz=',psmz +! print*,'pslmu(zetau)=',pslmu( zetau ) +! print*,'zetau=',zetau +! print*,'------------------------' + + simm = pslmu( zetalu ) - psmz + rlogu + pshz = pslhu( zetat ) + simh = pslhu( zetalt ) - pshz + rlogt + else + zetalu = min( zetalu, ztmax ) + zetalt = min( zetalt, ztmax ) + + psmz = pslms( zetau ) + +! print*,'-----------4------------' +! print*,'psmz=',psmz +! print*,'pslms(zetau)=',pslms( zetau ) +! print*,'zetau=',zetau +! print*,'------------------------' + + simm = pslms( zetalu ) - psmz + rlogu + pshz = pslhs( zetat ) + simh = pslhs( zetalt ) - pshz + rlogt + endif ! end if_rlmo_block + + endif ! end if_ilech_block + +! --- ... beljaars correction for ustar + + ustar = max( sqrt( cm*sqrt( du2+wstar2 ) ), epsust ) + +! --- ... zilitinkevitch fix for zt + + zt = exp( zilfc*sqrt( ustar*z0 ) ) * z0 + + zslt = zlvl + zt + rlogt = log( zslt/zt ) + + ustark = ustar * vkrm + cm = max( ustark/simm, cxch ) + ch = max( ustark/simh, cxch ) + +! --- ... if statements to avoid tangent linear problems near zero + + if (btgh*ch*dthv /= 0.0) then + wstar2 = wwst2 * abs(btgh*ch*dthv) ** (2.0/3.0) + else + wstar2 = 0.0 + endif + + rlmn = elfc*ch*dthv / ustar**3 + rlma = rlmo*wold + rlmn*wnew + + rlmo = rlma + + enddo ! end do_itr_loop + +! print*,'----------------------------' +! print*,'sfcdif output ! ! ! ! ! ! ! ! ! ! ! !' +! +! print*,'zlvl=',zlvl +! print*,'z0=',z0 +! print*,'t1v=',t1v +! print*,'th2v=',th2v +! print*,'sfcspd=',sfcspd +! print*,'czil=',czil +! print*,'cm=',cm +! print*,'ch=',ch +! print*,'----------------------------' +! + return +!................................... + end subroutine sfcdif +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates snow fraction (0->1). + subroutine snfrac (sneqv,snup,salp,snowh,sncovr, & + xlai,shdfac,fvb,gama,fbur, & + fgsn,ztopv,zbotv,ua_phys) +!................................... +! --- inputs: +! & ( sneqv, snup, salp, snowh, & +! --- outputs: +! & sncovr & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snfrac calculatexsnow fraction (0 -> 1) ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sneqv - real, snow water equivalent (m) 1 ! +! snup - real, threshold sneqv depth above which sncovr=1 1 ! +! salp - real, tuning parameter 1 ! +! snowh - real, snow depth (m) 1 ! +! ! +! outputs to the calling program: ! +! sncovr - real, fractional snow cover 1 ! +! ! +! ==================== end of description ===================== ! +! + implicit none +! --- inputs: + real (kind=kind_phys), intent(in) :: sneqv, snup, salp, snowh + logical, intent(in) :: ua_phys ! ua: flag for ua option + real (kind=kind_phys), intent(in) :: ztopv ! ua: height of canopy top + real (kind=kind_phys), intent(in) :: zbotv ! ua: height of canopy bottom + real (kind=kind_phys), intent(in) :: shdfac ! ua: vegetation fraction + real (kind=kind_phys), intent(in) :: ztopv ! flag for ua option + + real (kind=kind_phys), intent(inout) :: xlai ! ua: lai modified by snow + + real (kind=kind_phys), parameter :: snupgrd = 0.02 ! ua: swe limit for ground cover + +! --- outputs: + real (kind=kind_phys), intent(out) :: sncovr + real (kind=kind_phys), intent(out) :: fvb ! ua: frac. veg. w/snow beneath + real (kind=kind_phys), intent(out) :: gama ! ua: = exp(-1.* xlai) + real (kind=kind_phys), intent(out) :: fbur ! ua: fraction of canopy buried + real (kind=kind_phys), intent(out) :: fgsn ! ua: ground snow cover fraction + +! --- locals: + real (kind=kind_phys) :: rsnow, z0n + +! +!===> ... begin here +! +! --- ... snup is veg-class dependent snowdepth threshhold (set in routine +! redprm) above which snocvr=1. + + if (sneqv < snup) then + rsnow = sneqv / snup + sncovr = 1.0 - (exp(-salp*rsnow) - rsnow*exp(-salp)) + else + sncovr = 1.0 + endif + + z0n = 0.035 + +! --- ... formulation of dickinson et al. 1986 + +! sncovr = snowh / (snowh + 5.0*z0n) + +! --- ... formulation of marshall et al. 1994 + +! sncovr = sneqv / (sneqv + 2.0*z0n) + + if(ua_phys) then + +! ---------------------------------------------------------------------- +! fgsn: fraction of soil covered with snow +! ---------------------------------------------------------------------- + if (sneqv < snupgrd) then + fgsn = sneqv / snupgrd + else + fgsn = 1.0 + end if +! ---------------------------------------------------------------------- +! fbur: vertical fraction of vegetation covered by snow +! grass, crop, and shrub: multiply 0.4 by ztopv and zbotv because +! they will be pressed down by the snow. +! forest: don't need to change ztopv and zbotv. +! ---------------------------------------------------------------------- + + if(zbotv > 0. .and. snowh > zbotv) then + if(zbotv <= 0.5) then + fbur = (snowh - 0.4*zbotv) / (0.4*(ztopv-zbotv)) ! short veg. + else + fbur = (snowh - zbotv) / (ztopv-zbotv) ! tall veg. + endif + else + fbur = 0. + endif + + fbur = min(max(fbur,0.0),1.0) + +! xlai is adjusted for vertical burying by snow + xlai = xlai * (1.0 - fbur) +! ---------------------------------------------------------------------- +! snow-covered soil: (1-shdfac)*fgsn +! vegetation with snow above due to burial fveg_sn_ab = shdfac*fbur +! snow on the ground that can be "seen" by satellite +! (if xlai goes to zero): gama*fvb +! where gama = exp(-xlai) +! ---------------------------------------------------------------------- + +! vegetation with snow below + fvb = shdfac * fgsn * (1.0 - fbur) + +! gama is used to divide fvb into two parts: +! gama=1 for xlai=0 and gama=0 for xlai=6 + gama = exp(-1.* xlai) + else + ! define intent(out) terms for .not. ua_phys case + fvb = 0.0 + gama = 0.0 + fbur = 0.0 + fgsn = 0.0 + end if ! ua_phys + +! + return +!................................... + end subroutine snfrac +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates soil moisture and heat flux values and +!! update soil moisture content and soil heat content values for the +!! case when a snow pack is present. + subroutine snopac +!................................... +! --- inputs: +! & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, & +! & cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, & +! & bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, & +! & zsoil, dwsat, dksat, zbot, shdfac, ice, rtdis, quartz, & +! & fxexp, csoil, flx2, snowng, & +! --- input/outputs: +! & prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, & +! & sh2o, tbot, beta, & +! --- outputs: +! & smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, & +! & ett, snomlt, drip, dew, flx1, flx3, esnow & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snopac calculates soil moisture and heat flux values and ! +! update soil moisture content and soil heat content values for the ! +! case when a snow pack is present. ! +! ! +! ! +! subprograms called: evapo, smflx, shflx, snowpack +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! etp - real, potential evaporation 1 ! +! prcp - real, precip rate 1 ! +! smcmax - real, porosity 1 ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! dt - real, time step 1 ! +! df1 - real, thermal diffusivity m ! +! sfcems - real, lw surface emissivity 1 ! +! sfctmp - real, sfc temperature 1 ! +! t24 - real, sfctmp**4 1 ! +! th2 - real, sfc air potential temperature 1 ! +! fdown - real, net solar + downward lw flux at sfc 1 ! +! epsca - real, 1 ! +! bexp - real, soil type "b" parameter 1 ! +! pc - real, plant coeff 1 ! +! rch - real, companion coefficient of ch 1 ! +! rr - real, 1 ! +! cfactr - real, canopy water parameters 1 ! +! slope - real, linear reservoir coefficient 1 ! +! kdt - real, 1 ! +! frzx - real, frozen ground parameter 1 ! +! psisat - real, saturated soil potential 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! dwsat - real, saturated soil diffusivity 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! zbot - real, specify depth of lower bd soil 1 ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! rtdis - real, root distribution nsoil ! +! quartz - real, soil quartz content 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! csoil - real, soil heat capacity 1 ! +! flx2 - real, freezing rain latent heat flux 1 ! +! snowng - logical, snow flag 1 ! +! ! +! input/outputs from and to the calling program: ! +! prcp1 - real, effective precip 1 ! +! cmc - real, canopy moisture content 1 ! +! t1 - real, ground/canopy/snowpack eff skin temp 1 ! +! stc - real, soil temperature nsoil ! +! sncovr - real, snow cover 1 ! +! sneqv - real, water-equivalent snow depth 1 ! +! sndens - real, snow density 1 ! +! snowh - real, snow depth 1 ! +! sh2o - real, unfrozen soil moisture nsoil ! +! tbot - real, bottom soil temperature 1 ! +! beta - real, ratio of actual/potential evap 1 ! +! ! +! outputs to the calling program: ! +! smc - real, total soil moisture nsoil ! +! ssoil - real, upward soil heat flux 1 ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff 1 ! +! runoff3 - real, excess of porosity for a given soil layer 1 ! +! edir - real, direct soil evaporation 1 ! +! ec - real, canopy water evaporation 1 ! +! et - real, plant transpiration nsoil ! +! ett - real, total plant transpiration 1 ! +! snomlt - real, snow melt water equivalent 1 ! +! drip - real, through-fall of precip 1 ! +! dew - real, dewfall (or frostfall) 1 ! +! flx1 - real, precip-snow sfc flux 1 ! +! flx3 - real, phase-change heat flux from snowmelt 1 ! +! esnow - real, sublimation from snowpack 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + real, parameter :: esdmin = 1.e-6 + +! --- inputs: +! integer, intent(in) :: nsoil, nroot, ice + +! real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, smcref, & +! & smcwlt, smcdry, cmcmax, dt, df1, sfcems, sfctmp, t24, & +! & th2, fdown, epsca, bexp, pc, rch, rr, cfactr, slope, kdt, & +! & frzx, psisat, dwsat, dksat, zbot, shdfac, quartz, & +! & csoil, fxexp, flx2, zsoil(nsoil), rtdis(nsoil) + +! logical, intent(in) :: snowng + +! --- input/outputs: +! real (kind=kind_phys), intent(inout) :: prcp1, t1, sncovr, sneqv, & +! & sndens, snowh, cmc, tbot, beta, sh2o(nsoil), stc(nsoil) + +! --- outputs: +! real (kind=kind_phys), intent(out) :: ssoil, runoff1, runoff2, & +! & runoff3, edir, ec, et(nsoil), ett, snomlt, drip, dew, & +! & flx1, flx3, esnow, smc(nsoil) + +! --- locals: + real (kind=kind_phys):: denom, dsoil, dtot, etp1, ssoil1, & + & snoexp, ex, t11, t12, t12a, t12b, yy, zz1, seh, t14, & + & ec1, edir1, ett1, etns, etns1, esnow1, esnow2, etanrg, & + & et1(nsoil) + + integer k + +! data snoexp /1.0/ !!! <----- for noah v2.7 + data snoexp /2.0/ !!! <----- for noah v2.7.1 + +! --- ... convert potential evap (etp) from kg m-2 s-1 to m s-1 and then to an +! amount (m) given timestep (dt) and call it an effective snowpack +! reduction amount, esnow2 (m) for a snowcover fraction = 1.0. this is +! the amount the snowpack would be reduced due to sublimation from the +! snow sfc during the timestep. sublimation will proceed at the +! potential rate unless the snow depth is less than the expected +! snowpack reduction. for snowcover fraction = 1.0, 0=edir=et=ec, and +! hence total evap = esnow = sublimation (potential evap rate) + +! --- ... if sea-ice (ice=1) or glacial-ice (ice=-1), snowcover fraction = 1.0, +! and sublimation is at the potential rate. +! for non-glacial land (ice=0), if snowcover fraction < 1.0, total +! evaporation < potential due to non-potential contribution from +! non-snow covered fraction. + + prcp1 = prcp1 * 0.001 + + edir = 0.0 + edir1 = 0.0 + + ec = 0.0 + ec1 = 0.0 + + do k = 1, nsoil + et (k) = 0.0 + et1(k) = 0.0 + enddo + + ett = 0.0 + ett1 = 0.0 + etns = 0.0 + etns1 = 0.0 + esnow = 0.0 + esnow1= 0.0 + esnow2= 0.0 + + dew = 0.0 + etp1 = etp * 0.001 + + if (etp < 0.0) then + +! --- ... if etp<0 (downward) then dewfall (=frostfall in this case). + + dew = -etp1 + esnow2 = etp1 * dt + etanrg = etp * ((1.0-sncovr)*lsubc + sncovr*lsubs) + + else + +! --- ... etp >= 0, upward moisture flux + + if (ice /= 0) then ! for sea-ice and glacial-ice case + + esnow = etp + esnow1 = esnow * 0.001 + esnow2 = esnow1 * dt + etanrg = esnow * lsubs + + else ! for non-glacial land case + + if (sncovr < 1.0) then + + call evapo & +! --- inputs: + & ( nsoil, nroot, cmc, cmcmax, etp1, dt, zsoil, & + & sh2o, smcmax, smcwlt, smcref, smcdry, pc, & + & shdfac, cfactr, rtdis, fxexp, & +! --- outputs: + & etns1, edir1, ec1, et1, ett1 & + & ) + + edir1 = edir1 * (1.0 - sncovr) + ec1 = ec1 * (1.0 - sncovr) + + do k = 1, nsoil + et1(k) = et1(k) * (1.0 - sncovr) + enddo + + ett1 = ett1 * (1.0 - sncovr) + etns1 = etns1 * (1.0 - sncovr) + + edir = edir1 * 1000.0 + ec = ec1 * 1000.0 + + do k = 1, nsoil + et(k) = et1(k) * 1000.0 + enddo + + ett = ett1 * 1000.0 + etns = etns1 * 1000.0 + + endif ! end if_sncovr_block + + esnow = etp * sncovr +! esnow1 = etp * 0.001 + esnow1 = esnow * 0.001 + esnow2 = esnow1 * dt + etanrg = esnow*lsubs + etns*lsubc + + endif ! end if_ice_block + + endif ! end if_etp_block + +! --- ... if precip is falling, calculate heat flux from snow sfc to newly +! accumulating precip. note that this reflects the flux appropriate for +! the not-yet-updated skin temperature (t1). assumes temperature of the +! snowfall striking the gound is =sfctmp (lowest model level air temp). + + flx1 = 0.0 + if ( snowng ) then +! --- ... fractional snowfall/rainfall + flx1 = (cpice* ffrozp + cph2o1*(1.-ffrozp)) & + & * prcp * (t1 - sfctmp) + else + if (prcp > 0.0) flx1 = cph2o1 * prcp * (t1 - sfctmp) + endif + +! --- ... calculate an 'effective snow-grnd sfc temp' (t12) based on heat +! fluxes between the snow pack and the soil and on net radiation. +! include flx1 (precip-snow sfc) and flx2 (freezing rain latent +! heat) fluxes. +! flx2 reflects freezing rain latent heat flux using t1 calculated +! in penman. + + dsoil = -0.5 * zsoil(1) + dtot = snowh + dsoil + denom = 1.0 + df1 / (dtot * rr * rch) + +! t12a = ( (fdown - flx1 - flx2 - sigma1*t24) / rch & +! & + th2 - sfctmp - beta*epsca ) / rr + t12a = ( (fdown - flx1 - flx2 - sfcems*sigma1*t24) / rch & + & + th2 - sfctmp - etanrg/rch ) / rr + + t12b = df1 * stc(1) / (dtot * rr * rch) + t12 = (sfctmp + t12a + t12b) / denom + +! --- ... if the 'effective snow-grnd sfc temp' is at or below freezing, no snow +! melt will occur. set the skin temp to this effective temp. reduce +! (by sublimination ) or increase (by frost) the depth of the snowpack, +! depending on sign of etp. +! update soil heat flux (ssoil) using new skin temperature (t1) +! since no snowmelt, set accumulated snowmelt to zero, set 'effective' +! precip from snowmelt to zero, set phase-change heat flux from snowmelt +! to zero. + + if (t12 <= tfreez) then + + t1 = t12 + ssoil = df1 * (t1 - stc(1)) / dtot +!wz ssoil = (t1 - stc (1)) * max(7.0, df1/dtot) + sneqv = max(0.0, sneqv-esnow2) + flx3 = 0.0 + ex = 0.0 + snomlt = 0.0 + + else + +! --- ... if the 'effective snow-grnd sfc temp' is above freezing, snow melt +! will occur. call the snow melt rate,ex and amt, snomlt. revise the +! effective snow depth. revise the skin temp because it would have chgd +! due to the latent heat released by the melting. calc the latent heat +! released, flx3. set the effective precip, prcp1 to the snow melt rate, +! ex for use in smflx. adjustment to t1 to account for snow patches. +! calculate qsat valid at freezing point. note that esat (saturation +! vapor pressure) value of 6.11e+2 used here is that valid at frzzing +! point. note that etp from call penman in sflx is ignored here in +! favor of bulk etp over 'open water' at freezing temp. +! update soil heat flux (s) using new skin temperature (t1) + +! --- ... noah v2.7.1 mek feb2004 +! non-linear weighting of snow vs non-snow covered portions of gridbox +! so with snoexp = 2.0 (>1), surface skin temperature is higher than +! for the linear case (snoexp = 1). + +! t1 = tfreez * sncovr**snoexp + t12 * (1.0 - sncovr**snoexp) + t1 = tfreez * max(0.01,sncovr**snoexp) + & + & t12 * (1.0 - max(0.01,sncovr**snoexp)) + + beta = 1.0 + ssoil = df1 * (t1 - stc(1)) / dtot + +! --- ... if potential evap (sublimation) greater than depth of snowpack. +! beta<1 +! snowpack has sublimated away, set depth to zero. + + if (sneqv-esnow2 <= esdmin) then + + sneqv = 0.0 + ex = 0.0 + snomlt = 0.0 + flx3 = 0.0 + + else + +! --- ... potential evap (sublimation) less than depth of snowpack, retain +! beta=1. + + sneqv = sneqv - esnow2 + seh = rch * (t1 - th2) + + t14 = t1 * t1 + t14 = t14 * t14 + + flx3 = fdown - flx1 - flx2 - sfcems*sigma1*t14 & + & - ssoil - seh - etanrg + if (flx3 <= 0.0) flx3 = 0.0 + + ex = flx3 * 0.001 / lsubf + +! --- ... snowmelt reduction depending on snow cover +! if snow cover less than 5% no snowmelt reduction +! note: does 'if' below fail to match the melt water with the melt +! energy? + +! if (sncovr > 0.05) ex = ex * sncovr + snomlt = ex * dt + +! --- ... esdmin represents a snowpack depth threshold value below which we +! choose not to retain any snowpack, and instead include it in snowmelt. + + if (sneqv-snomlt >= esdmin) then + + sneqv = sneqv - snomlt + + else + +! --- ... snowmelt exceeds snow depth + + ex = sneqv / dt + flx3 = ex * 1000.0 * lsubf + snomlt = sneqv + sneqv = 0.0 + + endif ! end if_sneqv-snomlt_block + + endif ! end if_sneqv-esnow2_block + +! prcp1 = prcp1 + ex + +! --- ... if non-glacial land, add snowmelt rate (ex) to precip rate to be used +! in subroutine smflx (soil moisture evolution) via infiltration. + +! --- ... for sea-ice and glacial-ice, the snowmelt will be added to subsurface +! runoff/baseflow later near the end of sflx (after return from call to +! subroutine snopac) + + if (ice == 0) prcp1 = prcp1 + ex + + endif ! end if_t12<=tfreez_block + +! --- ... final beta now in hand, so compute evaporation. evap equals etp +! unless beta<1. + +! eta = beta * etp + +! --- ... smflx returns updated soil moisture values for non-glacial land. +! if sea-ice (ice=1) or glacial-ice (ice=-1), skip call to smflx, since +! no soil medium for sea-ice or glacial-ice + + if (ice == 0) then + + call smflx & +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + + endif + +! --- ... before call shflx in this snowpack case, set zz1 and yy arguments to +! special values that ensure that ground heat flux calculated in shflx +! matches that already computed for below the snowpack, thus the sfc +! heat flux to be computed in shflx will effectively be the flux at the +! snow top surface. t11 is a dummy arguement so we will not use the +! skin temp value as revised by shflx. + + zz1 = 1.0 + yy = stc(1) - 0.5*ssoil*zsoil(1)*zz1 / df1 + t11 = t1 + +! --- ... shflx will calc/update the soil temps. note: the sub-sfc heat flux +! (ssoil1) and the skin temp (t11) output from this shflx call are not +! used in any subsequent calculations. rather, they are dummy variables +! here in the snopac case, since the skin temp and sub-sfc heat flux are +! updated instead near the beginning of the call to snopac. + + call shflx & +! --- inputs: + & ( nsoil, smc, smcmax, dt, yy, zz1, zsoil, zbot, & + & psisat, bexp, df1, ice, quartz, csoil, vegtyp, & +! --- input/outputs: + & stc, t11, tbot, sh2o, & +! --- outputs: + & ssoil1 & + & ) + +! --- ... snow depth and density adjustment based on snow compaction. yy is +! assumed to be the soil temperture at the top of the soil column. + + if (ice == 0) then ! for non-glacial land + + if (sneqv > 0.0) then + + call snowpack & +! --- inputs: + & ( sneqv, dt, t1, yy, & +! --- input/outputs: + & snowh, sndens & + & ) + + else + + sneqv = 0.0 + snowh = 0.0 + sndens = 0.0 +! sncond = 1.0 + sncovr = 0.0 + + endif ! end if_sneqv_block + +! --- ... over sea-ice or glacial-ice, if s.w.e. (sneqv) below threshold lower +! bound (0.01 m for sea-ice, 0.10 m for glacial-ice), then set at +! lower bound and store the source increment in subsurface runoff/ +! baseflow (runoff2). note: runoff2 is then a negative value (as +! a flag) over sea-ice or glacial-ice, in order to achieve water balance. + + elseif (ice == 1) then ! for sea-ice + + if (sneqv >= 0.01) then + + call snowpack & +! --- inputs: + & ( sneqv, dt, t1, yy, & +! --- input/outputs: + & snowh, sndens & + & ) + + else + +! sndens = sneqv / snowh +! runoff2 = -(0.01 - sneqv) / dt + sneqv = 0.01 + snowh = 0.05 + sncovr = 1.0 +! snowh = sneqv / sndens + + endif ! end if_sneqv_block + + else ! for glacial-ice + + if (sneqv >= 0.10) then + + call snowpack & +! --- inputs: + & ( sneqv, dt, t1, yy, & +! --- input/outputs: + & snowh, sndens & + & ) + + else + +! sndens = sneqv / snowh +! runoff2 = -(0.10 - sneqv) / dt + sneqv = 0.10 + snowh = 0.50 + sncovr = 1.0 +! snowh = sneqv / sndens + + endif ! end if_sneqv_block + + endif ! end if_ice_block + +! + return +!................................... + end subroutine snopac +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates snow depth and densitity to account +!! for the new snowfall. new values of snow depth & density returned. + subroutine snow_new +!................................... +! --- inputs: +! & ( sfctmp, sn_new, & +! --- input/outputs: +! & snowh, sndens & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snow_new calculates snow depth and densitity to account ! +! for the new snowfall. new values of snow depth & density returned. ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sfctmp - real, surface air temperature (k) 1 ! +! sn_new - real, new snowfall (m) 1 ! +! ! +! input/outputs from and to the calling program: ! +! snowh - real, snow depth (m) 1 ! +! sndens - real, snow density 1 ! +! (g/cm3=dimensionless fraction of h2o density) ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real(kind=kind_phys), intent(in) :: sfctmp, sn_new + +! --- input/outputs: +! real(kind=kind_phys), intent(inout) :: snowh, sndens + +! --- locals: + real(kind=kind_phys) :: dsnew, snowhc, hnewc, newsnc, tempc + +! +!===> ... begin here +! +! --- ... conversion into simulation units + + snowhc = snowh * 100.0 + newsnc = sn_new * 100.0 + tempc = sfctmp - tfreez + +! --- ... calculating new snowfall density depending on temperature +! equation from gottlib l. 'a general runoff model for +! snowcovered and glacierized basin', 6th nordic hydrological +! conference, vemadolen, sweden, 1980, 172-177pp. + + if (tempc <= -15.0) then + dsnew = 0.05 + else + dsnew = 0.05 + 0.0017*(tempc + 15.0)**1.5 + endif + +! --- ... adjustment of snow density depending on new snowfall + + hnewc = newsnc / dsnew + sndens = (snowhc*sndens + hnewc*dsnew) / (snowhc + hnewc) + snowhc = snowhc + hnewc + snowh = snowhc * 0.01 +! + return +!................................... + end subroutine snow_new +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates total roughness length over snow. + subroutine snowz0 +!................................... +! --- inputs: +! & ( sncovr, & +! --- input/outputs: +! & z0 & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snowz0 calculates total roughness length over snow ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sncovr - real, fractional snow cover 1 ! +! ! +! input/outputs from and to the calling program: ! +! z0 - real, roughness length (m) 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real(kind=kind_phys), intent(in) :: sncovr + +! --- input/outputs: +! real(kind=kind_phys), intent(inout) :: z0 + +! --- locals: + real(kind=kind_phys) :: z0s +! +!===> ... begin here +! +! z0s = 0.001 ! snow roughness length:=0.001 (m) +! --- ... current noah lsm condition - mbek, 09-oct-2001 + z0s = z0 + + z0 = (1.0 - sncovr)*z0 + sncovr*z0s + +! + return +!................................... + end subroutine snowz0 +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates thermal diffusivity and conductivity +!! of the soil for a given point and time. + subroutine tdfcnd & +! --- inputs: + & ( smc, qz, smcmax, sh2o, & +! --- outputs: + & df & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine tdfcnd calculates thermal diffusivity and conductivity ! +! of the soil for a given point and time. ! +! ! +! peters-lidard approach (peters-lidard et al., 1998) ! +! june 2001 changes: frozen soil condition. ! +! ! +! subprogram called: none ! +! ! +! use as in peters-lidard, 1998 (modif. from johansen, 1975). ! +! pablo grunmann, 08/17/98 ! +! refs.: ! +! farouki, o.t.,1986: thermal properties of soils. series on rock ! +! and soil mechanics, vol. 11, trans tech, 136 pp. ! +! johansen, o., 1975: thermal conductivity of soils. ph.d. thesis, ! +! university of trondheim, ! +! peters-lidard, c. d., et al., 1998: the effect of soil thermal ! +! conductivity parameterization on surface energy fluxes ! +! and temperatures. journal of the atmospheric sciences, ! +! vol. 55, pp. 1209-1224. ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! smc - real, top layer total soil moisture 1 ! +! qz - real, quartz content (soil type dependent) 1 ! +! smcmax - real, porosity 1 ! +! sh2o - real, top layer unfrozen soil moisture 1 ! +! ! +! outputs: ! +! df - real, soil thermal diffusivity and conductivity 1 ! +! ! +! locals: ! +! thkw - water thermal conductivity 1 ! +! thkqtz - thermal conductivity for quartz 1 ! +! thko - thermal conductivity for other soil components 1 ! +! thkqtz - thermal conductivity for the solids combined 1 ! +! thkice - ice thermal conductivity 1 ! +! ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + real (kind=kind_phys), intent(in) :: smc, qz, smcmax, sh2o + +! --- output: + real (kind=kind_phys), intent(out) :: df + +! --- locals: + real (kind=kind_phys) :: gammd, thkdry, ake, thkice, thko, & + & thkqtz, thksat, thks, thkw, satratio, xu, xunfroz +! +!===> ... begin here +! +! --- ... if the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils + +! --- ... saturation ratio: + + satratio = smc / smcmax + +! --- ... parameters w/(m.k) + thkice = 2.2 + thkw = 0.57 + thko = 2.0 +! if (qz <= 0.2) thko = 3.0 + thkqtz = 7.7 + +! --- ... solids' conductivity + + thks = (thkqtz**qz) * (thko**(1.0-qz)) + +! --- ... unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen)) + + xunfroz = (sh2o + 1.e-9) / (smc + 1.e-9) + +! --- ... unfrozen volume for saturation (porosity*xunfroz) + + xu=xunfroz*smcmax + +! --- ... saturated thermal conductivity + + thksat = thks**(1.-smcmax) * thkice**(smcmax-xu) * thkw**(xu) + +! --- ... dry density in kg/m3 + + gammd = (1.0 - smcmax) * 2700.0 + +! --- ... dry thermal conductivity in w.m-1.k-1 + + thkdry = (0.135*gammd + 64.7) / (2700.0 - 0.947*gammd) + + if ( sh2o+0.0005 < smc ) then ! frozen + + ake = satratio + + else ! unfrozen + +! --- ... range of validity for the kersten number (ake) + if ( satratio > 0.1 ) then + +! --- ... kersten number (using "fine" formula, valid for soils containing +! at least 5% of particles with diameter less than 2.e-6 meters.) +! (for "coarse" formula, see peters-lidard et al., 1998). + + ake = log10( satratio ) + 1.0 + + else + +! --- ... use k = kdry + ake = 0.0 + + endif ! end if_satratio_block + + endif ! end if_sh2o+0.0005_block + +! --- ... thermal conductivity + + df = ake * (thksat - thkdry) + thkdry +! + return +!................................... + end subroutine tdfcnd +!----------------------------------- + + +!*********************************************! +! section-2 2nd level subprograms ! +!*********************************************! + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates soil moisture flux. The soil moisture +!! content (smc - a per unit volume measurement) is a dependent variable +!! that is updated with prognostic equations. The canopy moisture content +!! (cmc) is also updated. Frozen ground version: new states added: sh2o, +!! and frozen ground correction factor, frzfact and paramter slope. + subroutine evapo & +! --- inputs: + & ( nsoil, nroot, cmc, cmcmax, etp1, dt, zsoil, & + & sh2o, smcmax, smcwlt, smcref, smcdry, pc, & + & shdfac, cfactr, rtdis, fxexp, & +! --- outputs: + & eta1, edir1, ec1, et1, ett1 & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine evapo calculates soil moisture flux. the soil moisture ! +! content (smc - a per unit volume measurement) is a dependent variable! +! that is updated with prognostic eqns. the canopy moisture content ! +! (cmc) is also updated. frozen ground version: new states added: ! +! sh2o, and frozen ground correction factor, frzfact and parameter ! +! slope. ! +! ! +! ! +! subprogram called: devap, transp ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! cmc - real, canopy moisture content 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! etp1 - real, potential evaporation 1 ! +! dt - real, time step 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! sh2o - real, unfrozen soil moisture nsoil ! +! smcmax - real, porosity 1 ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! pc - real, plant coeff 1 ! +! cfactr - real, canopy water parameters 1 ! +! rtdis - real, root distribution nsoil ! +! fxexp - real, bare soil evaporation exponent 1 ! +! ! +! outputs to calling program: ! +! eta1 - real, latent heat flux 1 ! +! edir1 - real, direct soil evaporation 1 ! +! ec1 - real, canopy water evaporation 1 ! +! et1 - real, plant transpiration nsoil ! +! ett1 - real, total plant transpiration 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil, nroot + + real (kind=kind_phys), intent(in) :: cmc, cmcmax, etp1, dt, pc, & + & smcmax, smcwlt, smcref, smcdry, shdfac, cfactr, fxexp, & + & zsoil(nsoil), sh2o(nsoil), rtdis(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: eta1, edir1, ec1, ett1, & + & et1(nsoil) + +! --- locals: + real (kind=kind_phys) :: cmc2ms + + integer :: i, k + +! +!===> ... begin here +! +! --- ... executable code begins here if the potential evapotranspiration +! is greater than zero. + + edir1 = 0.0 + ec1 = 0.0 + + do k = 1, nsoil + et1(k) = 0.0 + enddo + ett1 = 0.0 + + if (etp1 > 0.0) then + +! --- ... retrieve direct evaporation from soil surface. call this function +! only if veg cover not complete. +! frozen ground version: sh2o states replace smc states. + + if (shdfac < 1.0) then + + call devap & +! --- inputs: + & ( etp1, sh2o(1), shdfac, smcmax, smcdry, fxexp, & +! --- outputs: + & edir1 & + & ) + + endif + +! --- ... initialize plant total transpiration, retrieve plant transpiration, +! and accumulate it for all soil layers. + + if (shdfac > 0.0) then + + call transp & +! --- inputs: + & ( nsoil, nroot, etp1, sh2o, smcwlt, smcref, & + & cmc, cmcmax, zsoil, shdfac, pc, cfactr, rtdis, & +! --- outputs: + & et1 & + & ) + + do k = 1, nsoil + ett1 = ett1 + et1(k) + enddo + +! --- ... calculate canopy evaporation. +! if statements to avoid tangent linear problems near cmc=0.0. + + if (cmc > 0.0) then + ec1 = shdfac * ( (cmc/cmcmax)**cfactr ) * etp1 + else + ec1 = 0.0 + endif + +! --- ... ec should be limited by the total amount of available water +! on the canopy. -f.chen, 18-oct-1994 + + cmc2ms = cmc / dt + ec1 = min ( cmc2ms, ec1 ) + endif + + endif ! end if_etp1_block + +! --- ... total up evap and transp types to obtain actual evapotransp + + eta1 = edir1 + ett1 + ec1 + +! + return +!................................... + end subroutine evapo +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine updates the temperature state of the soil column +!! based on the thermal diffusion equation and update the frozen soil +!! moisture content based on the temperature. + subroutine shflx & +! --- inputs: + & ( nsoil, smc, smcmax, dt, yy, zz1, zsoil, zbot, & + & psisat, bexp, df1, ice, quartz, csoil, vegtyp, & +! --- input/outputs: + & stc, t1, tbot, sh2o, & +! --- outputs: + & ssoil & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine shflx updates the temperature state of the soil column ! +! based on the thermal diffusion equation and update the frozen soil ! +! moisture content based on the temperature. ! +! ! +! subprogram called: hstep, hrtice, hrt ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! smc - real, total soil moisture nsoil ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! dt - real, time step 1 ! +! yy - real, soil temperature at the top of column 1 ! +! zz1 - real, 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! zbot - real, specify depth of lower bd soil 1 ! +! psisat - real, saturated soil potential 1 ! +! bexp - real, soil type "b" parameter 1 ! +! df1 - real, thermal diffusivity and conductivity 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! quartz - real, soil quartz content 1 ! +! csoil - real, soil heat capacity 1 ! +! vegtyp - integer, vegtation type 1 ! +! ! +! input/outputs: ! +! stc - real, soil temp nsoil ! +! t1 - real, ground/canopy/snowpack eff skin temp 1 ! +! tbot - real, bottom soil temp 1 ! +! sh2o - real, unfrozen soil moisture nsoil ! +! ! +! outputs: ! +! ssoil - real, upward soil heat flux 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- parameter constants: + real (kind=kind_phys), parameter :: ctfil1 = 0.5 + real (kind=kind_phys), parameter :: ctfil2 = 1.0 - ctfil1 + +! --- inputs: + integer, intent(in) :: nsoil, ice, vegtyp + + real (kind=kind_phys), intent(in) :: smc(nsoil), smcmax, dt, yy, & + & zz1, zsoil(nsoil), zbot, psisat, bexp, df1, quartz, csoil + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: stc(nsoil), t1, tbot, & + & sh2o(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: ssoil + +! --- locals: + real (kind=kind_phys) :: ai(nsold), bi(nsold), ci(nsold), oldt1, & + & rhsts(nsold), stcf(nsold), stsoil(nsoil) + + integer :: i + +! +!===> ... begin here +! + oldt1 = t1 + do i = 1, nsoil + stsoil(i) = stc(i) + enddo + +! --- ... hrt routine calcs the right hand side of the soil temp dif eqn + + if (ice /= 0) then + +! --- ... sea-ice case, glacial-ice case + + call hrtice & +! --- inputs: + & ( nsoil, stc, zsoil, yy, zz1, df1, ice, & +! --- input/outputs: + & tbot, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + + call hstep & +! --- inputs: + & ( nsoil, stc, dt, & +! --- input/outputs: + & rhsts, ai, bi, ci, & +! --- outputs: + & stcf & + & ) + + else + +! --- ... land-mass case + + call hrt & +! --- inputs: + & ( nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, & + & zbot, psisat, dt, bexp, df1, quartz, csoil,vegtyp, & + & shdfac, & +! --- input/outputs: + & sh2o, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + + call hstep & +! --- inputs: + & ( nsoil, stc, dt, & +! --- input/outputs: + & rhsts, ai, bi, ci, & +! --- outputs: + & stcf & + & ) + + endif + + do i = 1, nsoil + stc(i) = stcf(i) + enddo + +! --- ... in the no snowpack case (via routine nopac branch,) update the grnd +! (skin) temperature here in response to the updated soil temperature +! profile above. (note: inspection of routine snopac shows that t1 +! below is a dummy variable only, as skin temperature is updated +! differently in routine snopac) + + t1 = (yy + (zz1 - 1.0)*stc(1)) / zz1 + t1 = ctfil1*t1 + ctfil2*oldt1 + + do i = 1, nsoil + stc(i) = ctfil1*stc(i) + ctfil2*stsoil(i) + enddo + +! --- ... calculate surface soil heat flux + + ssoil = df1*(stc(1) - t1) / (0.5*zsoil(1)) + +! + return +!................................... + end subroutine shflx +!----------------------------------- + + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates soil moisture flux. The soil moisture +!! content (smc - a per unit vulume measurement) is a dependent variable +!! that is updated with prognostic equations. The canopy moisture content +!! (cmc) is also updated. Frozen ground version: new states added: sh2o and +!! frozen ground correction factor, frzx and parameter slope. + subroutine smflx & +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine smflx calculates soil moisture flux. the soil moisture ! +! content (smc - a per unit volume measurement) is a dependent variable! +! that is updated with prognostic eqns. the canopy moisture content ! +! (cmc) is also updated. frozen ground version: new states added: sh2o! +! and frozen ground correction factor, frzx and parameter slope. ! +! ! +! ! +! subprogram called: srt, sstep ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! dt - real, time step 1 ! +! kdt - real, 1 ! +! smcmax - real, porosity 1 ! +! smcwlt - real, wilting point 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! prcp1 - real, effective precip 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! slope - real, linear reservoir coefficient 1 ! +! frzx - real, frozen ground parameter 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! shdfac - real, aeral coverage of green veg 1 ! +! edir1 - real, direct soil evaporation 1 ! +! ec1 - real, canopy water evaporation 1 ! +! et1 - real, plant transpiration nsoil ! +! ! +! input/outputs: ! +! cmc - real, canopy moisture content 1 ! +! sh2o - real, unfrozen soil moisture nsoil ! +! ! +! outputs: ! +! smc - real, total soil moisture nsoil ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff (baseflow) 1 ! +! runoff3 - real, excess of porosity 1 ! +! drip - real, through-fall of precip and/or dew 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), intent(in) :: dt, kdt, smcmax, smcwlt, & + & cmcmax, prcp1, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1(nsoil), zsoil(nsoil) + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: cmc, sh2o(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: smc(nsoil), runoff1, & + & runoff2, runoff3, drip + +! --- locals: + real (kind=kind_phys) :: dummy, excess, pcpdrp, rhsct, trhsct, & + & rhstt(nsold), sice(nsold), sh2oa(nsold), sh2ofg(nsold), & + & ai(nsold), bi(nsold), ci(nsold) + + integer :: i, k +! +!===> ... begin here +! +! --- ... executable code begins here. + + dummy = 0.0 + +! --- ... compute the right hand side of the canopy eqn term ( rhsct ) + + rhsct = shdfac*prcp1 - ec1 + +! --- ... convert rhsct (a rate) to trhsct (an amount) and add it to +! existing cmc. if resulting amt exceeds max capacity, it becomes +! drip and will fall to the grnd. + + drip = 0.0 + trhsct = dt * rhsct + excess = cmc + trhsct + + if (excess > cmcmax) drip = excess - cmcmax + +! --- ... pcpdrp is the combined prcp1 and drip (from cmc) that goes into +! the soil + + pcpdrp = (1.0 - shdfac)*prcp1 + drip/dt + +! --- ... store ice content at each soil layer before calling srt & sstep + + do i = 1, nsoil + sice(i) = smc(i) - sh2o(i) + enddo + +! --- ... call subroutines srt and sstep to solve the soil moisture +! tendency equations. + +! --- if the infiltrating precip rate is nontrivial, +! (we consider nontrivial to be a precip total over the time step +! exceeding one one-thousandth of the water holding capacity of +! the first soil layer) +! then call the srt/sstep subroutine pair twice in the manner of +! time scheme "f" (implicit state, averaged coefficient) +! of section 2 of kalnay and kanamitsu (1988, mwr, vol 116, +! pages 1945-1958)to minimize 2-delta-t oscillations in the +! soil moisture value of the top soil layer that can arise because +! of the extreme nonlinear dependence of the soil hydraulic +! diffusivity coefficient and the hydraulic conductivity on the +! soil moisture state +! otherwise call the srt/sstep subroutine pair once in the manner of +! time scheme "d" (implicit state, explicit coefficient) +! of section 2 of kalnay and kanamitsu +! pcpdrp is units of kg/m**2/s or mm/s, zsoil is negative depth in m + +! if ( pcpdrp .gt. 0.0 ) then + if ( (pcpdrp*dt) > (0.001*1000.0*(-zsoil(1))*smcmax) ) then + +! --- ... frozen ground version: +! smc states replaced by sh2o states in srt subr. sh2o & sice states +! included in sstep subr. frozen ground correction factor, frzx +! added. all water balance calculations using unfrozen water + + call srt & +! --- inputs: + & ( nsoil, edir1, et1, sh2o, sh2o, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + + call sstep & +! --- inputs: + & ( nsoil, sh2o, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & dummy, rhstt, ai, bi, ci, & +! --- outputs: + & sh2ofg, runoff3, smc & + & ) + + do k = 1, nsoil + sh2oa(k) = (sh2o(k) + sh2ofg(k)) * 0.5 + enddo + + call srt & +! --- inputs: + & ( nsoil, edir1, et1, sh2o, sh2oa, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + + call sstep & +! --- inputs: + & ( nsoil, sh2o, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & cmc, rhstt, ai, bi, ci, & +! --- outputs: + & sh2o, runoff3, smc & + & ) + + else + + call srt & +! --- inputs: + & ( nsoil, edir1, et1, sh2o, sh2o, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + + call sstep & +! --- inputs: + & ( nsoil, sh2o, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & cmc, rhstt, ai, bi, ci, & +! --- outputs: + & sh2o, runoff3, smc & + & ) + + endif + +! runof = runoff +! + return +!................................... + end subroutine smflx +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates compaction of a snowpack under conditions of +!! increasing snow density, as obtained from an approximate solution of +!! E. Anderson's differential equation (3.29),NOAA technical report NWS 19, +!! by Victor Koren, 03/25/95. subroutine will return new values of \a snowh +!! and \a sndens . + subroutine snowpack & +! --- inputs: + & ( esd, dtsec, tsnow, tsoil, & +! --- input/outputs: + & snowh, sndens & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snowpack calculates compaction of snowpack under ! +! conditions of increasing snow density, as obtained from an ! +! approximate solution of e. anderson's differential equation (3.29),! +! noaa technical report nws 19, by victor koren, 03/25/95. ! +! subroutine will return new values of snowh and sndens ! +! ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! esd - real, water equivalent of snow (m) 1 ! +! dtsec - real, time step (sec) 1 ! +! tsnow - real, snow surface temperature (k) 1 ! +! tsoil - real, soil surface temperature (k) 1 ! +! ! +! input/outputs: ! +! snowh - real, snow depth (m) 1 ! +! sndens - real, snow density 1 ! +! (g/cm3=dimensionless fraction of h2o density) ! +! ! +! ==================== end of description ===================== ! +! +! --- parameter constants: + real (kind=kind_phys), parameter :: c1 = 0.01 + real (kind=kind_phys), parameter :: c2 = 21.0 + +! --- inputs: + real (kind=kind_phys), intent(in) :: esd, dtsec, tsnow, tsoil + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: snowh, sndens + +! --- locals: + real (kind=kind_phys) :: bfac, dsx, dthr, dw, snowhc, pexp, & + & tavgc, tsnowc, tsoilc, esdc, esdcx + + integer :: ipol, j +! +!===> ... begin here +! +! --- ... conversion into simulation units + + snowhc = snowh * 100.0 + esdc = esd * 100.0 + dthr = dtsec / 3600.0 + tsnowc = tsnow - tfreez + tsoilc = tsoil - tfreez + +! --- ... calculating of average temperature of snow pack + + tavgc = 0.5 * (tsnowc + tsoilc) + +! --- ... calculating of snow depth and density as a result of compaction +! sndens=ds0*(exp(bfac*esd)-1.)/(bfac*esd) +! bfac=dthr*c1*exp(0.08*tavgc-c2*ds0) +! note: bfac*esd in sndens eqn above has to be carefully treated +! numerically below: +! c1 is the fractional increase in density (1/(cm*hr)) +! c2 is a constant (cm3/g) kojima estimated as 21 cms/g + + if (esdc > 1.e-2) then + esdcx = esdc + else + esdcx = 1.e-2 + endif + + bfac = dthr*c1 * exp(0.08*tavgc - c2*sndens) + +! dsx = sndens * ((dexp(bfac*esdc)-1.0) / (bfac*esdc)) + +! --- ... the function of the form (e**x-1)/x imbedded in above expression +! for dsx was causing numerical difficulties when the denominator "x" +! (i.e. bfac*esdc) became zero or approached zero (despite the fact +! that the analytical function (e**x-1)/x has a well defined limit +! as "x" approaches zero), hence below we replace the (e**x-1)/x +! expression with an equivalent, numerically well-behaved +! polynomial expansion. + +! --- ... number of terms of polynomial expansion, and hence its accuracy, +! is governed by iteration limit "ipol". +! ipol greater than 9 only makes a difference on double +! precision (relative errors given in percent %). +! ipol=9, for rel.error <~ 1.6 e-6 % (8 significant digits) +! ipol=8, for rel.error <~ 1.8 e-5 % (7 significant digits) +! ipol=7, for rel.error <~ 1.8 e-4 % ... + + ipol = 4 + pexp = 0.0 + + do j = ipol, 1, -1 +! pexp = (1.0 + pexp)*bfac*esdc /real(j+1) + pexp = (1.0 + pexp)*bfac*esdcx/real(j+1) + enddo + pexp = pexp + 1. + + dsx = sndens * pexp + +! --- ... above line ends polynomial substitution +! end of koren formulation + +!! --- ... base formulation (cogley et al., 1990) +! convert density from g/cm3 to kg/m3 + +!! dsm = sndens * 1000.0 + +!! dsx = dsm + dtsec*0.5*dsm*gs2*esd / & +!! & (1.e7*exp(-0.02*dsm + kn/(tavgc+273.16)-14.643)) + +!! --- ... convert density from kg/m3 to g/cm3 + +!! dsx = dsx / 1000.0 + +!! --- ... end of cogley et al. formulation + +! --- ... set upper/lower limit on snow density + + dsx = max( min( dsx, 0.40 ), 0.05 ) + sndens = dsx + +! --- ... update of snow depth and density depending on liquid water +! during snowmelt. assumed that 13% of liquid water can be +! stored in snow per day during snowmelt till snow density 0.40. + + if (tsnowc >= 0.0) then + dw = 0.13 * dthr / 24.0 + sndens = sndens*(1.0 - dw) + dw + if (sndens > 0.40) sndens = 0.40 + endif + +! --- ... calculate snow depth (cm) from snow water equivalent and snow +! density. change snow depth units to meters + + snowhc = esdc / sndens + snowh = snowhc * 0.01 + +! + return +!................................... + end subroutine snowpack +!----------------------------------- + + +!*********************************************! +! section-3 3rd or lower level subprograms ! +!*********************************************! + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subrtouine calculates direct soil evaporation. + subroutine devap & +! --- inputs: + & ( etp1, smc, shdfac, smcmax, smcdry, fxexp, & +! --- outputs: + & edir1 & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine devap calculates direct soil evaporation ! +! ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! etp1 - real, potential evaporation 1 ! +! smc - real, unfrozen soil moisture 1 ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! ! +! outputs: ! +! edir1 - real, direct soil evaporation 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + real (kind=kind_phys), intent(in) :: etp1, smc, shdfac, smcmax, & + & smcdry, fxexp + +! --- outputs: + real (kind=kind_phys), intent(out) :: edir1 + +! --- locals: + real (kind=kind_phys) :: fx, sratio +! +!===> ... begin here +! +! --- ... direct evap a function of relative soil moisture availability, +! linear when fxexp=1. +! fx > 1 represents demand control +! fx < 1 represents flux control + + sratio = (smc - smcdry) / (smcmax - smcdry) + + if (sratio > 0.0) then + fx = sratio**fxexp + fx = max ( min ( fx, 1.0 ), 0.0 ) + else + fx = 0.0 + endif + +! --- ... allow for the direct-evap-reducing effect of shade + + edir1 = fx * ( 1.0 - shdfac ) * etp1 +! + return +!................................... + end subroutine devap +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates amount of supercooled liquid soil water +!! content if temperature is below 273.15K (t0). It requires Newton-type +!! iteration to solve the nonlinear implicit equation given in eqn 17 +!! of Koren et al.(1999) \cite koren_et_al_1999. +!! +!! New version (June 2001): much faster and more accurate Newton iteration +!! achieved by first taking log of eqn cited above -- less than 4 (typically +!! 1 or 2) iterations achieves convergence. Also, explicit 1-step solution +!! option for special case of paramter ck=0, which reduces the orginal +!! implicit equation to a simpler explicit form, known as the "flerchinger eqn". +!! Improved handling of solution in the limit of freezing point temperature t0. + subroutine frh2o & +! --- inputs: + & ( tkelv, smc, sh2o, smcmax, bexp, psis, & +! --- outputs: + & liqwat & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine frh2o calculates amount of supercooled liquid soil water ! +! content if temperature is below 273.15k (t0). requires newton-type ! +! iteration to solve the nonlinear implicit equation given in eqn 17 ! +! of koren et al (1999, jgr, vol 104(d16), 19569-19585). ! +! ! +! new version (june 2001): much faster and more accurate newton ! +! iteration achieved by first taking log of eqn cited above -- less ! +! than 4 (typically 1 or 2) iterations achieves convergence. also, ! +! explicit 1-step solution option for special case of parameter ck=0, ! +! which reduces the original implicit equation to a simpler explicit ! +! form, known as the "flerchinger eqn". improved handling of solution ! +! in the limit of freezing point temperature t0. ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! tkelv - real, temperature (k) 1 ! +! smc - real, total soil moisture content (volumetric) 1 ! +! sh2o - real, liquid soil moisture content (volumetric) 1 ! +! smcmax - real, saturation soil moisture content 1 ! +! bexp - real, soil type "b" parameter 1 ! +! psis - real, saturated soil matric potential 1 ! +! ! +! outputs: ! +! liqwat - real, supercooled liquid water content 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + real (kind=kind_phys), parameter :: ck = 8.0 +! real (kind=kind_phys), parameter :: ck = 0.0 + real (kind=kind_phys), parameter :: blim = 5.5 + real (kind=kind_phys), parameter :: error = 0.005 + +! --- inputs: + real (kind=kind_phys), intent(in) :: tkelv, smc, sh2o, smcmax, & + & bexp, psis + +! --- outputs: + real (kind=kind_phys), intent(out) :: liqwat + +! --- locals: + real (kind=kind_phys) :: bx, denom, df, dswl, fk, swl, swlk + + integer :: nlog, kcount +! +!===> ... begin here +! +! --- ... limits on parameter b: b < 5.5 (use parameter blim) +! simulations showed if b > 5.5 unfrozen water content is +! non-realistically high at very low temperatures. + + bx = bexp + if (bexp > blim) bx = blim + +! --- ... initializing iterations counter and iterative solution flag. + + nlog = 0 + kcount= 0 + +! --- ... if temperature not significantly below freezing (t0), sh2o = smc + + if (tkelv > (tfreez-1.e-3)) then + + liqwat = smc + + else + + if (ck /= 0.0) then + +! --- ... option 1: iterated solution for nonzero ck +! in koren et al, jgr, 1999, eqn 17 + +! --- ... initial guess for swl (frozen content) + + swl = smc - sh2o + +! --- ... keep within bounds. + + swl = max( min( swl, smc-0.02 ), 0.0 ) + +! --- ... start of iterations + + do while ( (nlog < 10) .and. (kcount == 0) ) + nlog = nlog + 1 + + df = alog( (psis*gs2/lsubf) * ( (1.0 + ck*swl)**2.0 ) & + & * (smcmax/(smc-swl))**bx ) - alog(-(tkelv-tfreez)/tkelv) + + denom = 2.0*ck/(1.0 + ck*swl) + bx/(smc - swl) + swlk = swl - df/denom + +! --- ... bounds useful for mathematical solution. + + swlk = max( min( swlk, smc-0.02 ), 0.0 ) + +! --- ... mathematical solution bounds applied. + + dswl = abs(swlk - swl) + swl = swlk + +! --- ... if more than 10 iterations, use explicit method (ck=0 approx.) +! when dswl less or eq. error, no more iterations required. + + if ( dswl <= error ) then + kcount = kcount + 1 + endif + enddo ! end do_while_loop + +! --- ... bounds applied within do-block are valid for physical solution. + + liqwat = smc - swl + + endif ! end if_ck_block + +! --- ... option 2: explicit solution for flerchinger eq. i.e. ck=0 +! in koren et al., jgr, 1999, eqn 17 +! apply physical bounds to flerchinger solution + + if (kcount == 0) then + fk = ( ( (lsubf/(gs2*(-psis))) & + & * ((tkelv-tfreez)/tkelv) )**(-1/bx) ) * smcmax + + fk = max( fk, 0.02 ) + + liqwat = min( fk, smc ) + endif + + endif ! end if_tkelv_block +! + return +!................................... + end subroutine frh2o +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates the right hand side of the time tendency +!! term of the soil thermal diffusion equation. Also to compute (prepare) +!! the matrix coefficients for the tri-diagonal matrix of the implicit time +!! scheme. + subroutine hrt & +! --- inputs: + & ( nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, & + & zbot, psisat, dt, bexp, df1, quartz, csoil, vegtyp, & + & shdfac, & +! --- input/outputs: + & sh2o, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine hrt calculates the right hand side of the time tendency ! +! term of the soil thermal diffusion equation. also to compute ! +! (prepare) the matrix coefficients for the tri-diagonal matrix of ! +! the implicit time scheme. ! +! ! +! subprogram called: tbnd, snksrc, tmpavg ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! stc - real, soil temperature nsoil ! +! smc - real, total soil moisture nsoil ! +! smcmax - real, porosity 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! yy - real, 1 ! +! zz1 - real, soil temperture at the top soil column 1 ! +! tbot - real, bottom soil temp 1 ! +! zbot - real, specify depth of lower bd soil 1 ! +! psisat - real, saturated soil potential 1 ! +! dt - real, time step 1 ! +! bexp - real, soil type "b" parameter 1 ! +! df1 - real, thermal diffusivity 1 ! +! quartz - real, soil quartz content 1 ! +! csoil - real, soil heat capacity 1 ! +! vegtyp - integer, vegetation type 1 ! +! ! +! input/outputs: ! +! sh2o - real, unfrozen soil moisture nsoil ! +! ! +! outputs: ! +! rhsts - real, time tendency of soil thermal diffusion nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil, vegtyp + + real (kind=kind_phys), intent(in) :: stc(nsoil), smc(nsoil), & + & smcmax, zsoil(nsoil), yy, zz1, tbot, zbot, psisat, dt, & + & bexp, df1, quartz, csoil, shdfac + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: sh2o(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: rhsts(nsoil), ai(nsold), & + & bi(nsold), ci(nsold) + +! --- locals: + real (kind=kind_phys) :: ddz, ddz2, denom, df1n, df1k, dtsdz, & + & dtsdz2, hcpct, qtot, ssoil, sice, tavg, tbk, tbk1, & + & tsnsr, tsurf, csoil_loc + + integer :: i, k + + logical :: itavg + +! +!===> ... begin here +! + csoil_loc=csoil + + if (ivegsrc == 1)then +!urban + if( vegtyp == 13 ) then +! csoil_loc=3.0e6 + csoil_loc=3.0e6*(1.-shdfac)+csoil*shdfac ! gvf + endif + endif + +! --- ... initialize logical for soil layer temperature averaging. + + itavg = .true. +! itavg = .false. + +! === begin section for top soil layer + +! --- ... calc the heat capacity of the top soil layer + + hcpct = sh2o(1)*cph2o2 + (1.0 - smcmax)*csoil_loc & + & + (smcmax - smc(1))*cp2 + (smc(1) - sh2o(1))*cpice1 + +! --- ... calc the matrix coefficients ai, bi, and ci for the top layer + + ddz = 1.0 / ( -0.5*zsoil(2) ) + ai(1) = 0.0 + ci(1) = (df1*ddz) / ( zsoil(1)*hcpct ) + bi(1) = -ci(1) + df1 / ( 0.5*zsoil(1)*zsoil(1)*hcpct*zz1 ) + +! --- ... calculate the vertical soil temp gradient btwn the 1st and 2nd soil +! layers. then calculate the subsurface heat flux. use the temp +! gradient and subsfc heat flux to calc "right-hand side tendency +! terms", or "rhsts", for top soil layer. + + dtsdz = (stc(1) - stc(2)) / (-0.5*zsoil(2)) + ssoil = df1 * (stc(1) - yy) / (0.5*zsoil(1)*zz1) + rhsts(1) = (df1*dtsdz - ssoil) / (zsoil(1)*hcpct) + +! --- ... next capture the vertical difference of the heat flux at top and +! bottom of first soil layer for use in heat flux constraint applied to +! potential soil freezing/thawing in routine snksrc. + + qtot = ssoil - df1*dtsdz + +! --- ... if temperature averaging invoked (itavg=true; else skip): +! set temp "tsurf" at top of soil column (for use in freezing soil +! physics later in subroutine snksrc). if snowpack content is +! zero, then tsurf expression below gives tsurf = skin temp. if +! snowpack is nonzero (hence argument zz1=1), then tsurf expression +! below yields soil column top temperature under snowpack. then +! calculate temperature at bottom interface of 1st soil layer for use +! later in subroutine snksrc + + if (itavg) then + + tsurf = (yy + (zz1-1)*stc(1)) / zz1 + + call tbnd & +! --- inputs: + & ( stc(1), stc(2), zsoil, zbot, 1, nsoil, & +! --- outputs: + & tbk & + & ) + + endif + +! --- ... calculate frozen water content in 1st soil layer. + + sice = smc(1) - sh2o(1) + +! --- ... if frozen water present or any of layer-1 mid-point or bounding +! interface temperatures below freezing, then call snksrc to +! compute heat source/sink (and change in frozen water content) +! due to possible soil water phase change + + if ( (sice > 0.0) .or. (tsurf < tfreez) .or. & + & (stc(1) < tfreez) .or. (tbk < tfreez) ) then + + if (itavg) then + + call tmpavg & +! --- inputs: + & ( tsurf, stc(1), tbk, zsoil, nsoil, 1, & +! --- outputs: + & tavg & + & ) + + else + + tavg = stc(1) + + endif ! end if_itavg_block + + call snksrc & +! --- inputs: + & ( nsoil, 1, tavg, smc(1), smcmax, psisat, bexp, dt, & + & qtot, zsoil, shdfac, & +! --- input/outputs: + & sh2o(1), & +! --- outputs: + & tsnsr & + & ) + + + rhsts(1) = rhsts(1) - tsnsr / ( zsoil(1)*hcpct ) + + endif ! end if_sice_block + +! === this ends section for top soil layer. + +! --- ... initialize ddz2 + + ddz2 = 0.0 + +! --- ... loop thru the remaining soil layers, repeating the above process +! (except subsfc or "ground" heat flux not repeated in lower layers) + + df1k = df1 + + do k = 2, nsoil + +! --- ... calculate heat capacity for this soil layer. + + hcpct = sh2o(k)*cph2o2 + (1.0 - smcmax)*csoil_loc & + & + (smcmax - smc(k))*cp2 + (smc(k) - sh2o(k))*cpice1 + + if (k /= nsoil) then + +! --- ... this section for layer 2 or greater, but not last layer. +! calculate thermal diffusivity for this layer. + + call tdfcnd & +! --- inputs: + & ( smc(k), quartz, smcmax, sh2o(k), & +! --- outputs: + & df1n & + & ) +!urban +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1n = 3.24 +! endif +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1n = 3.24*(1.-shdfac) + shdfac*df1n + endif + +! --- ... calc the vertical soil temp gradient thru this layer + + denom = 0.5 * (zsoil(k-1) - zsoil(k+1)) + dtsdz2 = (stc(k) - stc(k+1)) / denom + +! --- ... calc the matrix coef, ci, after calc'ng its partial product + + ddz2 = 2.0 / (zsoil(k-1) - zsoil(k+1)) + ci(k) = -df1n*ddz2 / ((zsoil(k-1) - zsoil(k)) * hcpct) + +! --- ... if temperature averaging invoked (itavg=true; else skip): +! calculate temp at bottom of layer. + + if (itavg) then + + call tbnd & +! --- inputs: + & ( stc(k), stc(k+1), zsoil, zbot, k, nsoil, & +! --- outputs: + & tbk1 & + & ) + + endif + + else + +! --- ... special case of bottom soil layer: calculate thermal diffusivity +! for bottom layer. + + call tdfcnd & +! --- inputs: + & ( smc(k), quartz, smcmax, sh2o(k), & +! --- outputs: + & df1n & + & ) +!urban +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1n = 3.24 +! endif +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1n = 3.24*(1.-shdfac) + shdfac*df1n + endif + +! --- ... calc the vertical soil temp gradient thru bottom layer. + + denom = 0.5 * (zsoil(k-1) + zsoil(k)) - zbot + dtsdz2 = (stc(k) - tbot) / denom + +! --- ... set matrix coef, ci to zero if bottom layer. + + ci(k) = 0.0 + +! --- ... if temperature averaging invoked (itavg=true; else skip): +! calculate temp at bottom of last layer. + + if (itavg) then + + call tbnd & +! --- inputs: + & ( stc(k), tbot, zsoil, zbot, k, nsoil, & +! --- outputs: + & tbk1 & + & ) + + endif + + endif ! end if_k_block + +! --- ... calculate rhsts for this layer after calc'ng a partial product. + + denom = (zsoil(k) - zsoil(k-1)) * hcpct + rhsts(k) = ( df1n*dtsdz2 - df1k*dtsdz ) / denom + + qtot = -1.0 * denom * rhsts(k) + sice = smc(k) - sh2o(k) + + if ( (sice > 0.0) .or. (tbk < tfreez) .or. & + & (stc(k) < tfreez) .or. (tbk1 < tfreez) ) then + + if (itavg) then + + call tmpavg & +! --- inputs: + & ( tbk, stc(k), tbk1, zsoil, nsoil, k, & +! --- outputs: + & tavg & + & ) + + else + tavg = stc(k) + endif + + call snksrc & +! --- inputs: + & ( nsoil, k, tavg, smc(k), smcmax, psisat, bexp, dt, & + & qtot, zsoil, shdfac, & +! --- input/outputs: + & sh2o(k), & +! --- outputs: + & tsnsr & + & ) + + rhsts(k) = rhsts(k) - tsnsr/denom + endif + +! --- ... calc matrix coefs, ai, and bi for this layer. + + ai(k) = - df1 * ddz / ((zsoil(k-1) - zsoil(k)) * hcpct) + bi(k) = -(ai(k) + ci(k)) + +! --- ... reset values of df1, dtsdz, ddz, and tbk for loop to next soil layer. + + tbk = tbk1 + df1k = df1n + dtsdz = dtsdz2 + ddz = ddz2 + + enddo ! end do_k_loop + +! + return +!................................... + end subroutine hrt +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates the right hand side of the time tendency +!! term of the soil thermal diffusion equation for sea-ice (ice = 1) or +!! glacial-ice (ice). + subroutine hrtice & +! --- inputs: + & ( nsoil, stc, zsoil, yy, zz1, df1, ice, & +! --- input/outputs: + & tbot, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine hrtice calculates the right hand side of the time tendency! +! term of the soil thermal diffusion equation for sea-ice (ice = 1) or ! +! glacial-ice (ice). compute (prepare) the matrix coefficients for the ! +! tri-diagonal matrix of the implicit time scheme. ! +! (note: this subroutine only called for sea-ice or glacial ice, but ! +! not for non-glacial land (ice = 0). ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! stc - real, soil temperature nsoil ! +! zsoil - real, soil depth (negative sign, as below grd) nsoil ! +! yy - real, soil temperature at the top of column 1 ! +! zz1 - real, 1 ! +! df1 - real, thermal diffusivity and conductivity 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! ! +! input/outputs: ! +! tbot - real, bottom soil temperature 1 ! +! ! +! outputs: ! +! rhsts - real, time tendency of soil thermal diffusion nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil, ice + + real (kind=kind_phys), intent(in) :: stc(nsoil), zsoil(nsoil), & + & yy, zz1, df1 + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: tbot + +! --- outputs: + real (kind=kind_phys), intent(out) :: rhsts(nsoil), ai(nsold), & + & bi(nsold), ci(nsold) + +! --- locals: + real (kind=kind_phys) :: ddz, ddz2, denom, dtsdz, dtsdz2, & + & hcpct, ssoil, zbot + + integer :: k + +! +!===> ... begin here +! +! --- ... set a nominal universal value of the sea-ice specific heat capacity, +! hcpct = 1880.0*917.0 = 1.72396e+6 (source: fei chen, 1995) +! set bottom of sea-ice pack temperature: tbot = 271.16 +! set a nominal universal value of glacial-ice specific heat capacity, +! hcpct = 2100.0*900.0 = 1.89000e+6 (source: bob grumbine, 2005) +! tbot passed in as argument, value from global data set + + if (ice == 1) then +! --- ... sea-ice + hcpct = 1.72396e+6 + tbot = 271.16 + else +! --- ... glacial-ice + hcpct = 1.89000e+6 + endif + +! --- ... the input argument df1 is a universally constant value of sea-ice +! and glacial-ice thermal diffusivity, set in sflx as df1 = 2.2. + +! --- ... set ice pack depth. use tbot as ice pack lower boundary temperature +! (that of unfrozen sea water at bottom of sea ice pack). assume ice +! pack is of n=nsoil layers spanning a uniform constant ice pack +! thickness as defined by zsoil(nsoil) in routine sflx. +! if glacial-ice, set zbot = -25 meters + + if (ice == 1) then +! --- ... sea-ice + zbot = zsoil(nsoil) + else +! --- ... glacial-ice + zbot = -25.0 + endif + +! --- ... calc the matrix coefficients ai, bi, and ci for the top layer + + ddz = 1.0 / (-0.5*zsoil(2)) + ai(1) = 0.0 + ci(1) = (df1*ddz) / (zsoil(1)*hcpct) + bi(1) = -ci(1) + df1 / (0.5*zsoil(1)*zsoil(1)*hcpct*zz1) + +! --- ... calc the vertical soil temp gradient btwn the top and 2nd soil +! layers. recalc/adjust the soil heat flux. use the gradient and +! flux to calc rhsts for the top soil layer. + + dtsdz = (stc(1) - stc(2)) / (-0.5*zsoil(2)) + ssoil = df1 * (stc(1) - yy) / (0.5*zsoil(1)*zz1) + rhsts(1) = (df1*dtsdz - ssoil) / (zsoil(1)*hcpct) + +! --- ... initialize ddz2 + + ddz2 = 0.0 + +! --- ... loop thru the remaining soil layers, repeating the above process + + do k = 2, nsoil + + if (k /= nsoil) then + +! --- ... calc the vertical soil temp gradient thru this layer. + + denom = 0.5 * (zsoil(k-1) - zsoil(k+1)) + dtsdz2 = (stc(k) - stc(k+1)) / denom + +! --- ... calc the matrix coef, ci, after calc'ng its partial product. + + ddz2 = 2.0 / (zsoil(k-1) - zsoil(k+1)) + ci(k) = -df1*ddz2 / ((zsoil(k-1) - zsoil(k))*hcpct) + + else + +! --- ... calc the vertical soil temp gradient thru the lowest layer. + + dtsdz2 = (stc(k) - tbot) & + & / (0.5*(zsoil(k-1) + zsoil(k)) - zbot) + +! --- ... set matrix coef, ci to zero. + + ci(k) = 0.0 + + endif ! end if_k_block + +! --- ... calc rhsts for this layer after calc'ng a partial product. + + denom = (zsoil(k) - zsoil(k-1)) * hcpct + rhsts(k) = (df1*dtsdz2 - df1*dtsdz) / denom + +! --- ... calc matrix coefs, ai, and bi for this layer. + + ai(k) = - df1*ddz / ((zsoil(k-1) - zsoil(k)) * hcpct) + bi(k) = -(ai(k) + ci(k)) + +! --- ... reset values of dtsdz and ddz for loop to next soil lyr. + + dtsdz = dtsdz2 + ddz = ddz2 + + enddo ! end do_k_loop +! + return +!................................... + end subroutine hrtice +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates/updates the soil temperature field. + subroutine hstep & +! --- inputs: + & ( nsoil, stcin, dt, & +! --- input/outputs: + & rhsts, ai, bi, ci, & +! --- outputs: + & stcout & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine hstep calculates/updates the soil temperature field. ! +! ! +! subprogram called: rosr12 ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! stcin - real, soil temperature nsoil ! +! dt - real, time step 1 ! +! ! +! input/outputs: ! +! rhsts - real, time tendency of soil thermal diffusion nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! outputs: ! +! stcout - real, updated soil temperature nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), intent(in) :: stcin(nsoil), dt + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: rhsts(nsoil), & + & ai(nsold), bi(nsold), ci(nsold) + +! --- outputs: + real (kind=kind_phys), intent(out) :: stcout(nsoil) + +! --- locals: + integer :: k + + real (kind=kind_phys) :: ciin(nsold), rhstsin(nsoil) + +! +!===> ... begin here +! +! --- ... create finite difference values for use in rosr12 routine + + do k = 1, nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1.0 + bi(k)*dt + ci(k) = ci(k) * dt + enddo + +! --- ... copy values for input variables before call to rosr12 + + do k = 1, nsoil + rhstsin(k) = rhsts(k) + enddo + + do k = 1, nsold + ciin(k) = ci(k) + enddo + +! --- ... solve the tri-diagonal matrix equation + + call rosr12 & +! --- inputs: + & ( nsoil, ai, bi, rhstsin, & +! --- input/outputs: + & ciin, & +! --- outputs: + & ci, rhsts & + & ) + +! --- ... calc/update the soil temps using matrix solution + + do k = 1, nsoil + stcout(k) = stcin(k) + ci(k) + enddo +! + return +!................................... + end subroutine hstep +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine inverts (solve) the tri-diagonal matrix problem. + subroutine rosr12 & +! --- inputs: + & ( nsoil, a, b, d, & +! --- input/outputs: + & c, & +! --- outputs: + & p, delta & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine rosr12 inverts (solve) the tri-diagonal matrix problem ! +! shown below: ! +! ! +! ### ### ### ### ### ###! +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # #! +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # #! +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) #! +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) #! +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) #! +! # . . # # . # = # . #! +! # . . # # . # # . #! +! # . . # # . # # . #! +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)#! +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)#! +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) #! +! ### ### ### ### ### ###! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! a - real, matrix coefficients nsoil ! +! b - real, matrix coefficients nsoil ! +! d - real, soil water time tendency nsoil ! +! ! +! input/outputs: ! +! c - real, matrix coefficients nsoil ! +! ! +! outputs: ! +! p - real, nsoil ! +! delta - real, nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), dimension(nsoil), intent(in) :: a, b, d + +! --- input/outputs: + real (kind=kind_phys), dimension(nsoil), intent(inout) :: c + +! --- outputs: + real (kind=kind_phys), dimension(nsoil), intent(out) :: p, delta + +! --- locals: + integer :: k, kk + +! +!===> ... begin here +! +! --- ... initialize eqn coef c for the lowest soil layer + + c(nsoil) = 0.0 + +! --- ... solve the coefs for the 1st soil layer + + p(1) = -c(1) / b(1) + delta(1) = d(1) / b(1) + +! --- ... solve the coefs for soil layers 2 thru nsoil + + do k = 2, nsoil + p(k) = -c(k) * ( 1.0 / (b(k) + a (k)*p(k-1)) ) + delta(k) = (d(k) - a(k)*delta(k-1)) & + & * ( 1.0 / (b(k) + a(k)*p(k-1)) ) + enddo + +! --- ... set p to delta for lowest soil layer + + p(nsoil) = delta(nsoil) + +! --- ... adjust p for soil layers 2 thru nsoil + + do k = 2, nsoil + kk = nsoil - k + 1 + p(kk) = p(kk)*p(kk+1) + delta(kk) + enddo +! + return +!................................... + end subroutine rosr12 +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates sink/source term of the termal diffusion equation. + subroutine snksrc & +! --- inputs: + & ( nsoil, k, tavg, smc, smcmax, psisat, bexp, dt, & + & qtot, zsoil, shdfac, & +! --- input/outputs: + & sh2o, & +! --- outputs: + & tsrc & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snksrc calculates sink/source term of the termal ! +! diffusion equation. ! +! ! +! subprograms called: frh2o ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! k - integer, index of soil layers 1 ! +! tavg - real, soil layer average temperature 1 ! +! smc - real, total soil moisture 1 ! +! smcmax - real, porosity 1 ! +! psisat - real, saturated soil potential 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dt - real, time step 1 ! +! qtot - real, tot vertical diff of heat flux 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! ! +! input/outputs: ! +! sh2o - real, available liqued water 1 ! +! ! +! outputs: ! +! tsrc - real, heat source/sink 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- parameter constants: + real (kind=kind_phys), parameter :: dh2o = 1.0000e3 + +! --- inputs: + integer, intent(in) :: nsoil, k + + real (kind=kind_phys), intent(in) :: tavg, smc, smcmax, psisat, & + & bexp, dt, qtot, zsoil(nsoil), shdfac + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: sh2o + +! --- outputs: + real (kind=kind_phys), intent(out) :: tsrc + +! --- locals: + real (kind=kind_phys) :: dz, free, xh2o + +! --- external functions: +! real (kind=kind_phys) :: frh2o + +!urban +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1=3.24 +! endif +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1 = 3.24*(1.-shdfac) + shdfac*df1 + endif +! +!===> ... begin here +! + if (k == 1) then + dz = -zsoil(1) + else + dz = zsoil(k-1) - zsoil(k) + endif + +! --- ... via function frh2o, compute potential or 'equilibrium' unfrozen +! supercooled free water for given soil type and soil layer temperature. +! function frh20 invokes eqn (17) from v. koren et al (1999, jgr, vol. +! 104, pg 19573). (aside: latter eqn in journal in centigrade units. +! routine frh2o use form of eqn in kelvin units.) + +! free = frh2o( tavg,smc,sh2o,smcmax,bexp,psisat ) + + call frh2o & +! --- inputs: + & ( tavg, smc, sh2o, smcmax, bexp, psisat, & +! --- outputs: + & free & + & ) + + +! --- ... in next block of code, invoke eqn 18 of v. koren et al (1999, jgr, +! vol. 104, pg 19573.) that is, first estimate the new amountof liquid +! water, 'xh2o', implied by the sum of (1) the liquid water at the begin +! of current time step, and (2) the freeze of thaw change in liquid +! water implied by the heat flux 'qtot' passed in from routine hrt. +! second, determine if xh2o needs to be bounded by 'free' (equil amt) or +! if 'free' needs to be bounded by xh2o. + + xh2o = sh2o + qtot*dt / (dh2o*lsubf*dz) + +! --- ... first, if freezing and remaining liquid less than lower bound, then +! reduce extent of freezing, thereby letting some or all of heat flux +! qtot cool the soil temp later in routine hrt. + + if ( xh2o < sh2o .and. xh2o < free) then + if ( free > sh2o ) then + xh2o = sh2o + else + xh2o = free + endif + endif + +! --- ... second, if thawing and the increase in liquid water greater than +! upper bound, then reduce extent of thaw, thereby letting some or +! all of heat flux qtot warm the soil temp later in routine hrt. + + if ( xh2o > sh2o .and. xh2o > free ) then + if ( free < sh2o ) then + xh2o = sh2o + else + xh2o = free + endif + endif + + xh2o = max( min( xh2o, smc ), 0.0 ) + +! --- ... calculate phase-change heat source/sink term for use in routine hrt +! and update liquid water to reflcet final freeze/thaw increment. + + tsrc = -dh2o * lsubf * dz * (xh2o - sh2o) / dt + sh2o = xh2o +! + return +!................................... + end subroutine snksrc +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates the right hand side of the time tendency +!! term of the soil water diffusion equation. Also to compute +!! (prepare) the matrix coefficients for the tri-diagonal matrix of +!! the implicit time scheme. + subroutine srt & +! --- inputs: + & ( nsoil, edir, et, sh2o, sh2oa, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + +! ===================================================================== ! +! description: ! +! subroutine srt calculates the right hand side of the time tendency ! +! term of the soil water diffusion equation. also to compute ! +! ( prepare ) the matrix coefficients for the tri-diagonal matrix ! +! of the implicit time scheme. ! +! ! +! subprogram called: wdfcnd ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! edir - real, direct soil evaporation 1 ! +! et - real, plant transpiration nsoil ! +! sh2o - real, unfrozen soil moisture nsoil ! +! sh2oa - real, nsoil ! +! pcpdrp - real, combined prcp and drip 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! dwsat - real, saturated soil diffusivity 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! smcmax - real, porosity 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dt - real, time step 1 ! +! smcwlt - real, wilting point 1 ! +! slope - real, linear reservoir coefficient 1 ! +! kdt - real, 1 ! +! frzx - real, frozen ground parameter 1 ! +! sice - real, ice content at each soil layer nsoil ! +! ! +! outputs: ! +! rhstt - real, soil water time tendency nsoil ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff (baseflow) 1 ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), dimension(nsoil), intent(in) :: et, & + & sh2o, sh2oa, zsoil, sice + + real (kind=kind_phys), intent(in) :: edir, pcpdrp, dwsat, dksat, & + & smcmax, smcwlt, bexp, dt, slope, kdt, frzx + +! --- outputs: + real (kind=kind_phys), intent(out) :: runoff1, runoff2, & + & rhstt(nsoil), ai(nsold), bi(nsold), ci(nsold) + + +! --- locals: + real (kind=kind_phys) :: acrt, dd, ddt, ddz, ddz2, denom, denom2, & + & dice, dsmdz, dsmdz2, dt1, fcr, infmax, mxsmc, mxsmc2, px, & + & numer, pddum, sicemax, slopx, smcav, sstt, sum, val, wcnd, & + & wcnd2, wdf, wdf2, dmax(nsold) + + integer :: cvfrz, ialp1, iohinf, j, jj, k, ks +! +!===> ... begin here +! +! --- ... frozen ground version: +! reference frozen ground parameter, cvfrz, is a shape parameter +! of areal distribution function of soil ice content which equals +! 1/cv. cv is a coefficient of spatial variation of soil ice content. +! based on field data cv depends on areal mean of frozen depth, and +! it close to constant = 0.6 if areal mean frozen depth is above 20 cm. +! that is why parameter cvfrz = 3 (int{1/0.6*0.6}). current logic +! doesn't allow cvfrz be bigger than 3 + + parameter (cvfrz = 3) + +c ---------------------------------------------------------------------- +! --- ... determine rainfall infiltration rate and runoff. include +! the infiltration formule from schaake and koren model. +! modified by q duan + + iohinf = 1 + +! --- ... let sicemax be the greatest, if any, frozen water content within +! soil layers. + + sicemax = 0.0 + do ks = 1, nsoil + if (sice(ks) > sicemax) sicemax = sice(ks) + enddo + +! --- ... determine rainfall infiltration rate and runoff + + pddum = pcpdrp + runoff1 = 0.0 + + if (pcpdrp /= 0.0) then + +! --- ... modified by q. duan, 5/16/94 + + dt1 = dt/86400. + smcav = smcmax - smcwlt + dmax(1) = -zsoil(1) * smcav + +! --- ... frozen ground version: + + dice = -zsoil(1) * sice(1) + + dmax(1) = dmax(1)*(1.0 - (sh2oa(1)+sice(1)-smcwlt)/smcav) + dd = dmax(1) + + do ks = 2, nsoil + +! --- ... frozen ground version: + + dice = dice + ( zsoil(ks-1) - zsoil(ks) ) * sice(ks) + + dmax(ks) = (zsoil(ks-1)-zsoil(ks))*smcav + dmax(ks) = dmax(ks)*(1.0 - (sh2oa(ks)+sice(ks)-smcwlt)/smcav) + dd = dd + dmax(ks) + enddo + +! --- ... val = (1.-exp(-kdt*sqrt(dt1))) +! in below, remove the sqrt in above + + val = 1.0 - exp(-kdt*dt1) + ddt = dd * val + + px = pcpdrp * dt + if (px < 0.0) px = 0.0 + + infmax = (px*(ddt/(px+ddt)))/dt + +! --- ... frozen ground version: +! reduction of infiltration based on frozen ground parameters + + fcr = 1. + + if (dice > 1.e-2) then + acrt = cvfrz * frzx / dice + sum = 1. + + ialp1 = cvfrz - 1 + do j = 1, ialp1 + k = 1 + + do jj = j+1,ialp1 + k = k * jj + enddo + + sum = sum + (acrt**( cvfrz-j)) / float (k) + enddo + + fcr = 1.0 - exp(-acrt) * sum + endif + + infmax = infmax * fcr + +! --- ... correction of infiltration limitation: +! if infmax .le. hydrolic conductivity assign infmax the value +! of hydrolic conductivity + +! mxsmc = max ( sh2oa(1), sh2oa(2) ) + mxsmc = sh2oa(1) + + call wdfcnd & +! --- inputs: + & ( mxsmc, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf, wcnd & + & ) + + infmax = max( infmax, wcnd ) + infmax = min( infmax, px ) + + if (pcpdrp > infmax) then + runoff1 = pcpdrp - infmax + pddum = infmax + endif + + endif ! end if_pcpdrp_block + +! --- ... to avoid spurious drainage behavior, 'upstream differencing' +! in line below replaced with new approach in 2nd line: +! 'mxsmc = max(sh2oa(1), sh2oa(2))' + + mxsmc = sh2oa(1) + + call wdfcnd & +! --- inputs: + & ( mxsmc, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf, wcnd & + & ) + +! --- ... calc the matrix coefficients ai, bi, and ci for the top layer + + ddz = 1.0 / ( -.5*zsoil(2) ) + ai(1) = 0.0 + bi(1) = wdf * ddz / ( -zsoil(1) ) + ci(1) = -bi(1) + +! --- ... calc rhstt for the top layer after calc'ng the vertical soil +! moisture gradient btwn the top and next to top layers. + + dsmdz = ( sh2o(1) - sh2o(2) ) / ( -.5*zsoil(2) ) + rhstt(1) = (wdf*dsmdz + wcnd - pddum + edir + et(1)) / zsoil(1) + sstt = wdf * dsmdz + wcnd + edir + et(1) + +! --- ... initialize ddz2 + + ddz2 = 0.0 + +! --- ... loop thru the remaining soil layers, repeating the abv process + + do k = 2, nsoil + denom2 = (zsoil(k-1) - zsoil(k)) + + if (k /= nsoil) then + slopx = 1.0 + +! --- ... again, to avoid spurious drainage behavior, 'upstream differencing' +! in line below replaced with new approach in 2nd line: +! 'mxsmc2 = max (sh2oa(k), sh2oa(k+1))' + + mxsmc2 = sh2oa(k) + + call wdfcnd & +! --- inputs: + & ( mxsmc2, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf2, wcnd2 & + & ) + +! --- ... calc some partial products for later use in calc'ng rhstt + + denom = (zsoil(k-1) - zsoil(k+1)) + dsmdz2 = (sh2o(k) - sh2o(k+1)) / (denom * 0.5) + +! --- ... calc the matrix coef, ci, after calc'ng its partial product + + ddz2 = 2.0 / denom + ci(k) = -wdf2 * ddz2 / denom2 + + else ! if_k_block + +! --- ... slope of bottom layer is introduced + + slopx = slope + +! --- ... retrieve the soil water diffusivity and hydraulic conductivity +! for this layer + + call wdfcnd & +! --- inputs: + & ( sh2oa(nsoil), smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf2, wcnd2 & + & ) + +! --- ... calc a partial product for later use in calc'ng rhstt + dsmdz2 = 0.0 + +! --- ... set matrix coef ci to zero + + ci(k) = 0.0 + + endif ! end if_k_block + +! --- ... calc rhstt for this layer after calc'ng its numerator + + numer = wdf2*dsmdz2 + slopx*wcnd2 - wdf*dsmdz - wcnd + et(k) + rhstt(k) = numer / (-denom2) + +! --- ... calc matrix coefs, ai, and bi for this layer + + ai(k) = -wdf * ddz / denom2 + bi(k) = -( ai(k) + ci(k) ) + +! --- ... reset values of wdf, wcnd, dsmdz, and ddz for loop to next lyr +! runoff2: sub-surface or baseflow runoff + + if (k == nsoil) then + runoff2 = slopx * wcnd2 + endif + + if (k /= nsoil) then + wdf = wdf2 + wcnd = wcnd2 + dsmdz= dsmdz2 + ddz = ddz2 + endif + enddo ! end do_k_loop +! + return +!................................... + end subroutine srt +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates/updates soil moisture content values and +!! canopy moisture content values. + subroutine sstep & +! --- inputs: + & ( nsoil, sh2oin, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & cmc, rhstt, ai, bi, ci, & +! --- outputs: + & sh2oout, runoff3, smc & + & ) + +! ===================================================================== ! +! description: ! +! subroutine sstep calculates/updates soil moisture content values ! +! and canopy moisture content values. ! +! ! +! subprogram called: rosr12 ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! sh2oin - real, unfrozen soil moisture nsoil ! +! rhsct - real, 1 ! +! dt - real, time step 1 ! +! smcmax - real, porosity 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! sice - real, ice content at each soil layer nsoil ! +! ! +! input/outputs: ! +! cmc - real, canopy moisture content 1 ! +! rhstt - real, soil water time tendency nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! outputs: ! +! sh2oout - real, updated soil moisture content nsoil ! +! runoff3 - real, excess of porosity 1 ! +! smc - real, total soil moisture nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: nsoil + + real (kind=kind_phys), dimension(nsoil), intent(in) :: sh2oin, & + & zsoil, sice + + real (kind=kind_phys), intent(in) :: rhsct, dt, smcmax, cmcmax + +! --- inout/outputs: + real (kind=kind_phys), intent(inout) :: cmc, rhstt(nsoil), & + & ai(nsold), bi(nsold), ci(nsold) + +! --- outputs: + real (kind=kind_phys), intent(out) :: sh2oout(nsoil), runoff3, & + & smc(nsoil) + +! --- locals: + real (kind=kind_phys) :: ciin(nsold), rhsttin(nsoil), ddz, stot, & + & wplus + + integer :: i, k, kk11 +! +!===> ... begin here +! +! --- ... create 'amount' values of variables to be input to the +! tri-diagonal matrix routine. + + do k = 1, nsoil + rhstt(k) = rhstt(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + enddo + +! --- ... copy values for input variables before call to rosr12 + + do k = 1, nsoil + rhsttin(k) = rhstt(k) + enddo + + do k = 1, nsold + ciin(k) = ci(k) + enddo + +! --- ... call rosr12 to solve the tri-diagonal matrix + + call rosr12 & +! --- inputs: + & ( nsoil, ai, bi, rhsttin, & +! --- input/outputs: + & ciin, & +! --- outputs: + & ci, rhstt & + & ) + +! --- ... sum the previous smc value and the matrix solution to get +! a new value. min allowable value of smc will be 0.02. +! runoff3: runoff within soil layers + + wplus = 0.0 + runoff3 = 0.0 + ddz = -zsoil(1) + + do k = 1, nsoil + if (k /= 1) ddz = zsoil(k - 1) - zsoil(k) + + sh2oout(k) = sh2oin(k) + ci(k) + wplus/ddz + + stot = sh2oout(k) + sice(k) + if (stot > smcmax) then + if (k == 1) then + ddz = -zsoil(1) + else + kk11 = k - 1 + ddz = -zsoil(k) + zsoil(kk11) + endif + + wplus = (stot - smcmax) * ddz + else + wplus = 0.0 + endif + + smc(k) = max( min( stot, smcmax ), 0.02 ) + sh2oout(k) = max( smc(k)-sice(k), 0.0 ) + enddo + + runoff3 = wplus + +! --- ... update canopy water content/interception (cmc). convert rhsct to +! an 'amount' value and add to previous cmc value to get new cmc. + + cmc = cmc + dt*rhsct + if (cmc < 1.e-20) cmc = 0.0 + cmc = min( cmc, cmcmax ) +! + return +!................................... + end subroutine sstep +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates temperature on the boundary of the +!! layer by interpolation of the middle layer temperatures. + subroutine tbnd & +! --- inputs: + & ( tu, tb, zsoil, zbot, k, nsoil, & +! --- outputs: + & tbnd1 & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine tbnd calculates temperature on the boundary of the ! +! layer by interpolation of the middle layer temperatures ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! tu - real, soil temperature 1 ! +! tb - real, bottom soil temp 1 ! +! zsoil - real, soil layer depth nsoil ! +! zbot - real, specify depth of lower bd soil 1 ! +! k - integer, soil layer index 1 ! +! nsoil - integer, number of soil layers 1 ! +! ! +! outputs: ! +! tbnd1 - real, temperature at bottom interface of the lyr 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: k, nsoil + + real (kind=kind_phys), intent(in) :: tu, tb, zbot, zsoil(nsoil) + +! --- output: + real (kind=kind_phys), intent(out) :: tbnd1 + +! --- locals: + real (kind=kind_phys) :: zb, zup + +! --- ... use surface temperature on the top of the first layer + + if (k == 1) then + zup = 0.0 + else + zup = zsoil(k-1) + endif + +! --- ... use depth of the constant bottom temperature when interpolate +! temperature into the last layer boundary + + if (k == nsoil) then + zb = 2.0*zbot - zsoil(k) + else + zb = zsoil(k+1) + endif + +! --- ... linear interpolation between the average layer temperatures + + tbnd1 = tu + (tb-tu)*(zup-zsoil(k))/(zup-zb) +! + return +!................................... + end subroutine tbnd +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates soil layer average temperature (tavg) +!! in freezing/thawing layer using up, down, and middle layer +!! temperature (tup, tdn, tm), where tup is at top boundary of layer, +!! tdn is at bottom boundary of layer. tm is layer prognostic state +!! temperature. + subroutine tmpavg & +! --- inputs: + & ( tup, tm, tdn, zsoil, nsoil, k, & +! --- outputs: + & tavg & + & ) + +! ===================================================================== ! +! description: ! +! subroutine tmpavg calculates soil layer average temperature (tavg) ! +! in freezing/thawing layer using up, down, and middle layer ! +! temperatures (tup, tdn, tm), where tup is at top boundary of ! +! layer, tdn is at bottom boundary of layer. tm is layer prognostic ! +! state temperature. ! +! ! +! ! +! subprogram called: none ! +! ! +! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! tup - real, temperature ar top boundary of layer 1 ! +! tm - real, layer prognostic state temperature 1 ! +! tdn - real, temperature ar bottom boundary of layer 1 ! +! zsoil - real, soil layer depth nsoil ! +! nsoil - integer, number of soil layers 1 ! +! k - integer, layer index 1 ! +! outputs: ! +! tavg - real, soil layer average temperature 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: nsoil, k + + real (kind=kind_phys), intent(in) :: tup, tm, tdn, zsoil(nsoil) + +! --- output: + real (kind=kind_phys), intent(out) :: tavg + +! --- locals: + real (kind=kind_phys) :: dz, dzh, x0, xdn, xup +! +!===> ... begin here +! + if (k == 1) then + dz = -zsoil(1) + else + dz = zsoil(k-1) - zsoil(k) + endif + + dzh = dz * 0.5 + + if (tup < tfreez) then + + if (tm < tfreez) then + if (tdn < tfreez) then ! tup, tm, tdn < t0 + tavg = (tup + 2.0*tm + tdn) / 4.0 + else ! tup & tm < t0, tdn >= t0 + x0 = (tfreez - tm) * dzh / (tdn - tm) + tavg = 0.5*(tup*dzh + tm*(dzh+x0)+tfreez*(2.*dzh-x0)) / dz + endif + else + if (tdn < tfreez) then ! tup < t0, tm >= t0, tdn < t0 + xup = (tfreez-tup) * dzh / (tm-tup) + xdn = dzh - (tfreez-tm) * dzh / (tdn-tm) + tavg = 0.5*(tup*xup + tfreez*(2.*dz-xup-xdn)+tdn*xdn) / dz + else ! tup < t0, tm >= t0, tdn >= t0 + xup = (tfreez-tup) * dzh / (tm-tup) + tavg = 0.5*(tup*xup + tfreez*(2.*dz-xup)) / dz + endif + endif + + else ! if_tup_block + + if (tm < tfreez) then + if (tdn < tfreez) then ! tup >= t0, tm < t0, tdn < t0 + xup = dzh - (tfreez-tup) * dzh / (tm-tup) + tavg = 0.5*(tfreez*(dz-xup) + tm*(dzh+xup)+tdn*dzh) / dz + else ! tup >= t0, tm < t0, tdn >= t0 + xup = dzh - (tfreez-tup) * dzh / (tm-tup) + xdn = (tfreez-tm) * dzh / (tdn-tm) + tavg = 0.5 * (tfreez*(2.*dz-xup-xdn) + tm*(xup+xdn)) / dz + endif + else + if (tdn < tfreez) then ! tup >= t0, tm >= t0, tdn < t0 + xdn = dzh - (tfreez-tm) * dzh / (tdn-tm) + tavg = (tfreez*(dz-xdn) + 0.5*(tfreez+tdn)*xdn) / dz + else ! tup >= t0, tm >= t0, tdn >= t0 + tavg = (tup + 2.0*tm + tdn) / 4.0 + endif + endif + + endif ! end if_tup_block +! + return +!................................... + end subroutine tmpavg +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates transpiration for the veg class. + subroutine transp & +! --- inputs: + & ( nsoil, nroot, etp1, smc, smcwlt, smcref, & + & cmc, cmcmax, zsoil, shdfac, pc, cfactr, rtdis, & +! --- outputs: + & et1 & + & ) + +! ===================================================================== ! +! description: ! +! subroutine transp calculates transpiration for the veg class. ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! etp1 - real, potential evaporation 1 ! +! smc - real, unfrozen soil moisture nsoil ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! cmc - real, canopy moisture content 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! pc - real, plant coeff 1 ! +! cfactr - real, canopy water parameters 1 ! +! rtdis - real, root distribution nsoil ! +! ! +! outputs: ! +! et1 - real, plant transpiration nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: nsoil, nroot + + real (kind=kind_phys), intent(in) :: etp1, smcwlt, smcref, & + & cmc, cmcmax, shdfac, pc, cfactr + + real (kind=kind_phys), dimension(nsoil), intent(in) :: smc, & + & zsoil, rtdis + +! --- output: + real (kind=kind_phys), dimension(nsoil), intent(out) :: et1 + +! --- locals: + real (kind=kind_phys) :: denom, etp1a, rtx, sgx, gx(7) + + integer :: i, k +! +!===> ... begin here +! +! --- ... initialize plant transp to zero for all soil layers. + + do k = 1, nsoil + et1(k) = 0.0 + enddo + +! --- ... calculate an 'adjusted' potential transpiration +! if statement below to avoid tangent linear problems near zero +! note: gx and other terms below redistribute transpiration by layer, +! et(k), as a function of soil moisture availability, while preserving +! total etp1a. + + if (cmc /= 0.0) then + etp1a = shdfac * pc * etp1 * (1.0 - (cmc /cmcmax) ** cfactr) + else + etp1a = shdfac * pc * etp1 + endif + + sgx = 0.0 + do i = 1, nroot + gx(i) = ( smc(i) - smcwlt ) / ( smcref - smcwlt ) + gx(i) = max ( min ( gx(i), 1.0 ), 0.0 ) + sgx = sgx + gx(i) + enddo + sgx = sgx / nroot + + denom = 0.0 + do i = 1, nroot + rtx = rtdis(i) + gx(i) - sgx + gx(i) = gx(i) * max ( rtx, 0.0 ) + denom = denom + gx(i) + enddo + if (denom <= 0.0) denom = 1.0 + + do i = 1, nroot + et1(i) = etp1a * gx(i) / denom + enddo + +! --- ... above code assumes a vertically uniform root distribution +! code below tests a variable root distribution + +! et(1) = ( zsoil(1) / zsoil(nroot) ) * gx * etp1a +! et(1) = ( zsoil(1) / zsoil(nroot) ) * etp1a + +! --- ... using root distribution as weighting factor + +! et(1) = rtdis(1) * etp1a +! et(1) = etp1a * part(1) + +! --- ... loop down thru the soil layers repeating the operation above, +! but using the thickness of the soil layer (rather than the +! absolute depth of each layer) in the final calculation. + +! do k = 2, nroot +! gx = ( smc(k) - smcwlt ) / ( smcref - smcwlt ) +! gx = max ( min ( gx, 1.0 ), 0.0 ) +! --- ... test canopy resistance +! gx = 1.0 +! et(k) = ((zsoil(k)-zsoil(k-1))/zsoil(nroot))*gx*etp1a +! et(k) = ((zsoil(k)-zsoil(k-1))/zsoil(nroot))*etp1a + +! --- ... using root distribution as weighting factor + +! et(k) = rtdis(k) * etp1a +! et(k) = etp1a*part(k) +! enddo + +! + return +!................................... + end subroutine transp +!----------------------------------- + + +!----------------------------------- +!>\ingroup Noah_LSM +!> This subroutine calculates soil water diffusivity and soil +!! hydraulic conductivity. + subroutine wdfcnd & +! --- inputs: + & ( smc, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf, wcnd & + & ) + +! ===================================================================== ! +! description: ! +! subroutine wdfcnd calculates soil water diffusivity and soil ! +! hydraulic conductivity. ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! smc - real, layer total soil moisture 1 ! +! smcmax - real, porosity 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! sicemax - real, max frozen water content in soil layer 1 ! +! ! +! outputs: ! +! wdf - real, soil water diffusivity 1 ! +! wcnd - real, soil hydraulic conductivity 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + real (kind=kind_phys), intent(in) :: smc, smcmax, bexp, dksat, & + & dwsat, sicemax + +! --- output: + real (kind=kind_phys), intent(out) :: wdf, wcnd + +! --- locals: + real (kind=kind_phys) :: expon, factr1, factr2, vkwgt +! +!===> ... begin here +! +! --- ... calc the ratio of the actual to the max psbl soil h2o content + + factr1 = min(1.0, max(0.0, 0.2/smcmax)) + factr2 = min(1.0, max(0.0, smc/smcmax)) + +! --- ... prep an expntl coef and calc the soil water diffusivity + + expon = bexp + 2.0 + wdf = dwsat * factr2 ** expon + +! --- ... frozen soil hydraulic diffusivity. very sensitive to the vertical +! gradient of unfrozen water. the latter gradient can become very +! extreme in freezing/thawing situations, and given the relatively +! few and thick soil layers, this gradient sufferes serious +! trunction errors yielding erroneously high vertical transports of +! unfrozen water in both directions from huge hydraulic diffusivity. +! therefore, we found we had to arbitrarily constrain wdf +! +! version d_10cm: ....... factr1 = 0.2/smcmax +! weighted approach....... pablo grunmann, 28_sep_1999. + + if (sicemax > 0.0) then + vkwgt = 1.0 / (1.0 + (500.0*sicemax)**3.0) + wdf = vkwgt*wdf + (1.0- vkwgt)*dwsat*factr1**expon + endif + +! --- ... reset the expntl coef and calc the hydraulic conductivity + + expon = (2.0 * bexp) + 3.0 + wcnd = dksat * factr2 ** expon +! + return +!................................... + end subroutine wdfcnd +!----------------------------------- + +! =========================== ! +! end contain programs ! +! =========================== ! + +!................................... + end subroutine gfssflx +!! @} +!----------------------------------- From a8d94041b3ad2388120d583e417a8bd009357bf3 Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Sat, 25 Jan 2020 00:02:27 +0000 Subject: [PATCH 05/16] Updating sflx_hafs for HAFS --- physics/sflx_hafs.f | 1008 +++++++++++++++++++++++++++---------------- 1 file changed, 626 insertions(+), 382 deletions(-) diff --git a/physics/sflx_hafs.f b/physics/sflx_hafs.f index e69271b38..e45a21177 100644 --- a/physics/sflx_hafs.f +++ b/physics/sflx_hafs.f @@ -284,6 +284,10 @@ subroutine gfssflx_hafs &! --- integer, parameter :: nsold = 4 !< max soil layers + integer :: defined_soil + integer :: defined_veg + integer :: defined_slope + ! real (kind=kind_phys), parameter :: gs = con_g !< con_g =9.80665 real (kind=kind_phys), parameter :: gs1 = 9.8 !< con_g in sfcdif real (kind=kind_phys), parameter :: gs2 = 9.81 !< con_g in snowpack, frh2o @@ -295,15 +299,15 @@ subroutine gfssflx_hafs &! --- ! real (kind=kind_phys), parameter :: rd = con_rd ! con_rd =287.05 real (kind=kind_phys), parameter :: rd1 = 287.04 ! con_rd in sflx, penman, canres real (kind=kind_phys), parameter :: cp = con_cp ! con_cp =1004.6 - real (kind=kind_phys), parameter :: cp1 = 1004.5 ! con_cp in sflx, canres + real (kind=kind_phys), parameter :: cp = 1004.5 ! con_cp in sflx, canres real (kind=kind_phys), parameter :: cp2 = 1004.0 ! con_cp in htr ! real (kind=kind_phys), parameter :: cph2o = con_cliq ! con_cliq=4.1855e+3 - real (kind=kind_phys), parameter :: cph2o1 = 4.218e+3 ! con_cliq in penman, snopac + real (kind=kind_phys), parameter :: cph2o = 4.218e+3 ! con_cliq in penman, snopac real (kind=kind_phys), parameter :: cph2o2 = 4.2e6 ! con_cliq in hrt *unit diff! real (kind=kind_phys), parameter :: cpice = con_csol ! con_csol=2.106e+3 real (kind=kind_phys), parameter :: cpice1 = 2.106e6 ! con_csol in hrt *unit diff! ! real (kind=kind_phys), parameter :: sigma = con_sbc ! con_sbc=5.6704e-8 - real (kind=kind_phys), parameter :: sigma1 = 5.67e-8 ! con_sbc in penman, nopac, snopac + real (kind=kind_phys), parameter :: sigma = 5.67e-8 ! con_sbc in penman, nopac, snopac ! --- inputs: integer, intent(in) :: nsoil, couple, icein, vegtyp, soiltyp, & @@ -365,6 +369,14 @@ subroutine gfssflx_hafs &! --- runoff3 = 0.0 snomlt = 0.0 + if ( .not. ua_phys ) then + flx4 = 0.0 + fvb = 0.0 + fbur = 0.0 + fgsn = 0.0 + endif + + ! --- ... define local variable ice to achieve: ! sea-ice case, ice = 1 ! non-glacial land, ice = 0 @@ -373,39 +385,7 @@ subroutine gfssflx_hafs &! --- ! note - for open-sea, sflx should *not* have been called. set green ! vegetation fraction (shdfac) = 0. -!> - Set ice = -1 and green vegetation fraction (shdfac) = 0 for glacial-ice land. - shdfac0 = shdfac - ice = icein - - if(ivegsrc == 2) then - if (vegtyp == 13) then - ice = -1 - shdfac = 0.0 - endif - endif - - if(ivegsrc == 1) then - if (vegtyp == 15) then - ice = -1 - shdfac = 0.0 - endif - endif - -!> - Calculate soil layer depth below ground. - if (ice == 1) then - - shdfac = 0.0 - -!> - For ice, set green vegetation fraction (shdfac) = 0. -!! and set sea-ice layers of equal thickness and sum to 3 meters - - do kz = 1, nsoil - zsoil(kz) = -3.0 * float(kz) / float(nsoil) - enddo - - else - -!> - Otherwise, calculate depth (negative) below ground from top skin sfc to +!> - Calculate depth (negative) below ground from top skin sfc to !! bottom of each soil layer. ! note - sign of zsoil is negative (denoting below ground) @@ -414,8 +394,6 @@ subroutine gfssflx_hafs &! --- zsoil(kz) = -sldpth(kz) + zsoil(kz-1) end do - endif ! end if_ice_block - ! --- ... next is crucial call to set the land-surface parameters, ! including soil-type and veg-type dependent parameters. ! set shdfac=0.0 for bare soil surfaces @@ -423,28 +401,33 @@ subroutine gfssflx_hafs &! --- !> - Call redprm() to set the land-surface paramters, !! including soil-type and veg-type dependent parameters. call redprm +!................................... +! --- inputs: + & ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, & +! --- outputs + & cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, & + & sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, & + & snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, & + & smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, & + & czil, xlai, csoil, lvcoef, laimin, laimax, & + & emissmin, emissmax, albedomin, albedomax, z0min, z0max, & + & ztopv, zbotv + & ) + ! if(ivegsrc == 1) then !only igbp type has urban !urban !MKB vegtyp=isurban in HWRF, need to check whether 13/31 and isurban are !same if(vegtyp == 13)then -!MKB All these parms below are uncommented in hwrf shdfac=0.05 rsmin=400.0 smcmax = 0.45 smcref = 0.42 smcwlt = 0.40 smcdry = 0.40 -!MKB End of mods -!MKB Commented below -! rsmin=400.0*(1-shdfac0)+40.0*shdfac0 ! gvf -! shdfac=shdfac0 ! gvf -! smcmax = 0.45*(1-shdfac0)+smcmax*shdfac0 -! smcref = 0.42*(1-shdfac0)+smcref*shdfac0 -! smcwlt = 0.40*(1-shdfac0)+smcwlt*shdfac0 -! smcdry = 0.40*(1-shdfac0)+smcdry*shdfac0 -!MKB + endif + if(shdfac >= shdmax )then embrd = emissmax if (.not. rdlai2d)then @@ -473,17 +456,17 @@ subroutine gfssflx_hafs &! --- interp_fraction = max ( interp_fraction, 0.0 ) ! Scale Emissivity and LAI between emissmin and emissmax ! by interp_fraction - embrd = ( ( 1.0 - interp_fraction ) * emissmin ) + & + embrd = ( ( 1.0 - interp_fraction ) * emissmin ) + & & ( interp_fraction * emissmax ) if (.not. rdlai2d)then - xlai = ( ( 1.0 - interp_fraction ) * laimin ) + & + xlai = ( ( 1.0 - interp_fraction ) * laimin ) + & & ( interp_fraction * laimax ) endif if (.not. usemonalb)then - alb = ( ( 1.0 - interp_fraction ) * albedomax ) + & + alb = ( ( 1.0 - interp_fraction ) * albedomax ) + & & ( interp_fraction * albedomin ) endif - z0brd = ( ( 1.0 - interp_fraction ) * z0min ) + & + z0brd = ( ( 1.0 - interp_fraction ) * z0min ) + & & ( interp_fraction * z0max ) else @@ -501,17 +484,7 @@ subroutine gfssflx_hafs &! --- endif - endif -! endif -! --- inputs: ! -! ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, ! -! --- outputs: ! -! cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, ! -! sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, ! -! snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, ! -! smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, ! -! z0, czil, xlai, csoil ) ! !> - Initialize precipitation logicals. @@ -532,14 +505,19 @@ subroutine gfssflx_hafs &! --- else sndens = sneqv / snowh if(sndens > 1.0) then +!MKB What is equiv of fatal_error in FV3? fatal_error( 'physical snow depth is less than snow water & & equiv.' ) +! stop 333 endif + call csnow -! --- inputs: ! -! ( sndens, ! -! sncond ) ! -! --- outputs: ! +! --- inputs: + & ( sndens, & +! --- outputs: + & sncond & + & ) + endif @@ -554,7 +532,7 @@ subroutine gfssflx_hafs &! --- !> snow defined when fraction of frozen precip (ffrozp) > 0.5, ! passed in from model microphysics. - if (ffrozp > 0.5) then !MKB + if (ffrozp > 0.5) then snowng = .true. else if (t1 <= tfreez) frzgra = .true. @@ -577,17 +555,21 @@ subroutine gfssflx_hafs &! --- !> - Call snow_new() to update snow density based on new snowfall, !! using old and new snow. call snow_new -! --- inputs: ! -! ( sfctmp, sn_new, ! -! --- input/outputs: ! -! snowh, sndens ) ! +!................................... +! --- inputs: + & ( sfctmp, sn_new, & +! --- input/outputs: + & snowh, sndens & + & ) !> - Call csnow() to update snow thermal conductivity. - call csnow -! --- inputs: ! -! ( sndens, ! -! --- outputs: ! -! sncond ) ! + call csnow +!................................... +! --- inputs: + & ( sndens, & +! --- outputs: + & sncond & + & ) else @@ -615,23 +597,24 @@ subroutine gfssflx_hafs &! --- ! --- ... determine snow fraction cover. ! determine surface albedo modification due to snowdepth state. !> - Call snfrac() to calculate snow fraction cover. - call snfrac -! --- inputs: ! -! ( sneqv, snup, salp, snowh, ! -! --- outputs: ! -! sncovr ) ! - call snfrac (sneqv,snup,salp,snowh,sncovr, & - xlai,shdfac,fvb,gama,fbur, & - fgsn,ztopv,zbotv,ua_phys) + + call snfrac & +!................................... +! --- inputs: + & ( sneqv, snup, salp, snowh, & + & ztopv, zbotv, shdfac, xlai, shdfac, ua_phys & +! --- outputs: + & sncovr, fvb, gama, fbur, fgsn & + & ) if ( ua_phys ) then if(sfctmp <= t1) then - ru = 0. + ru = 0.0 else - ru = 100.*shdfac*fgsn*min((sfctmp-t1)/5., 1.) & + ru = 100.0*shdfac*fgsn*min((sfctmp-t1)/5.0, 1.0) & & *(1.-exp(-xlai)) endif - ch = ch/(1.+ru*ch) + ch = ch/(1.0+ru*ch) endif sncovr = min(sncovr,0.98) @@ -639,25 +622,16 @@ subroutine gfssflx_hafs &! --- !> - Call alcalc() to calculate surface albedo modification due to snowdepth !! state. - call alcalc -! --- inputs: ! -! ( alb, snoalb, shdfac, shdmin, sncovr, tsnow, ! -! --- outputs: ! -! albedo ) ! + call alcalc & +!................................... +! --- inputs: + & ( alb, snoalb, shdfac, shdmin, sncovr, tsnow,embrd,dt,lvcoef & +! --- outputs: + & albedo, sfcems, snotime1 & + & ) endif ! end if_sneqv_block - endif ! end if_ice_block - -! --- ... thermal conductivity for sea-ice case, glacial-ice case -!> - Calculate thermal diffusivity (\a df1): -!> - For sea-ice case and glacial-ice case, this is constant(\f$df1=2.2\f$). - - if (ice /= 0) then - - df1 = 2.2 - - else !> - For non-glacial land case, call tdfcnd() to calculate the thermal !! diffusivity of top soil layer (\cite peters-lidard_et_al_1998). @@ -681,29 +655,26 @@ subroutine gfssflx_hafs &! --- call tdfcnd & ! --- inputs: - & ( smc(1), quartz, smcmax, sh2o(1), & + & ( smc(1), qz, smcmax, sh2o(1), bexp, psisat, soiltyp, & + & opt_thcnd, & ! --- outputs: & df1 & & ) -! if(ivegsrc == 1) then -!only igbp type has urban + !urban -! if ( vegtyp == 13 ) df1=3.24 -! endif + if ( vegtyp == 13 ) df1=3.24 !> - Add subsurface heat flux reduction effect from the !! overlying green canopy, adapted from section 2.1.2 of !! \cite peters-lidard_et_al_1997. !wz only urban for igbp type - if(ivegsrc == 1 .and. vegtyp == 13) then - df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) - else df1 = df1 * exp( sbeta*shdfac ) - endif - endif ! end if_ice_block + if ( sncovr .gt. 0.97 ) then + df1 = sncond + endif -! --- ... finally "plane parallel" snowpack effect following +!> --- ... finally "plane parallel" snowpack effect following ! v.j. linardini reference cited above. note that dtot is ! combined depth of snowdepth and thickness of first soil layer @@ -722,7 +693,7 @@ subroutine gfssflx_hafs &! --- ! --- ... 1. harmonic mean (series flow) ! df1 = (sncond*df1) / (frcsoi*sncond + frcsno*df1) -! df1h = (sncond*df1) / (frcsoi*sncond + frcsno*df1) + df1h = (sncond*df1) / (frcsoi*sncond + frcsno*df1) ! --- ... 2. arithmetic mean (parallel flow) @@ -750,14 +721,29 @@ subroutine gfssflx_hafs &! --- ! if (couple == 0) then ! uncoupled mode if (sncovr > 0.0) then - call snowz0 -! --- inputs: ! -! ( sncovr, ! -! --- input/outputs: ! -! z0 ) ! + call snowz0 & +!................................... +! --- inputs: + & ( sncovr,z0brd,snowh,fbur,fgsn,shdmax,ua_phys, & +! --- input/outputs: + & z0 & + & ) + + else + + z0=z0brd + + if(ua_phys) + + call snowz0 & +!................................... +! --- inputs: + & ( sncovr,z0brd,snowh,fbur,fgsn,shdmax,ua_phys, & +! --- input/outputs: + & z0 & + & ) endif -! endif !> - Calculate virtual temps and virtual potential temps needed by !! subroutines sfcdif and penman. @@ -794,74 +780,56 @@ subroutine gfssflx_hafs &! --- !! downward longwave (\a lwdn) as input of penman() and other surface !! energy budget calculations. - if (couple == 0) then !......uncoupled mode - -! --- ... uncoupled mode: -! compute surface exchange coefficients - - t1v = t1 * (1.0 + 0.61 * q2) - th2v = th2 * (1.0 + 0.61 * q2) - - call sfcdif -! --- inputs: ! -! ( zlvl, z0, t1v, th2v, sfcspd, czil, ! -! --- input/outputs: ! -! cm, ch ) ! - ! swnet = net solar radiation into the ground (w/m2; dn-up) from input ! fdown = net solar + downward lw flux at sfc (w/m2) fdown = swnet + lwdn - else !......coupled mode - -! --- ... coupled mode (couple .ne. 0): -! surface exchange coefficients computed externally and passed in, -! hence subroutine sfcdif not called. - -! swnet = net solar radiation into the ground (w/m2; dn-up) from input -! fdown = net solar + downward lw flux at sfc (w/m2) - fdown = swnet + lwdn - - endif ! end if_couple_block -! -! --- enhance cp as a function of z0 to mimic heat storage -! - cpx = cp - cpx1 = cp1 - cpfac = 1.0 - if (lheatstrg) then - if ((ivegsrc == 1 .and. vegtyp /= 13) - & .or. ivegsrc == 2) then - xx1 = (z0 - z0min) / (z0max - z0min) - xx2 = 1.0 + min(max(xx1, 0.0), 1.0) - cpx = cp * xx2 - cpx1 = cp1 * xx2 - cpfac = cp / cpx - endif - endif +! calc virtual temps and virtual potential temps needed by subroutines +! penman. + t2v = sfctmp * (1.0+ 0.61 * q2 ) + +! iout=0 +! if(iout.eq.1) then +! print*,'before penman' +! print*,' sfctmp',sfctmp,'sfcprs',sfcprs,'ch',ch,'t2v',t2v, & +! 'th2',th2,'prcp',prcp,'fdown',fdown,'t24',t24,'ssoil',ssoil, & +! 'q2',q2,'q2sat',q2sat,'etp',etp,'rch',rch, & +! 'epsca',epsca,'rr',rr ,'snowng',snowng,'frzgra',frzgra, & +! 'dqsdt2',dqsdt2,'flx2',flx2,'snowh',snowh,'sneqv',sneqv, & +! 'dsoil',dsoil,' frcsno',frcsno,' sncovr',sncovr,' dtot',dtot,& +! 'zsoil (1)',zsoil(1),' df1',df1,'t1',t1,' stc1',stc(1), & +! 'albedo',albedo,'smc',smc,'stc',stc,'sh2o',sh2o +! endif !> - Call penman() to calculate potential evaporation (\a etp), !! and other partial products and sums for later !! calculations. call penman -! --- inputs: ! -! ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, ! -! cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, ! -! --- outputs: ! -! t24, etp, rch, epsca, rr, flx2 ) ! +!................................... +! --- inputs: + & ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, & + & cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, & + & sncovr, sneqv, albedo, soldn, stc1, & +! --- outputs: + & t24, etp, rch, epsca, rr, flx2, etpn, flx4 & + & ) !> - Call canres() to calculate the canopy resistance and convert it !! into pc if nonzero greenness fraction. - if (shdfac > 0.) then + if ((shdfac > 0.0) .and. (xlai > 0.0)) then ! --- ... frozen ground extension: total soil water "smc" was replaced ! by unfrozen soil water "sh2o" in call to canres below - call canres +!MKB format + call canres (swdn,ch,sfctmp,q2,sfcprs,smc,zsoil,nsoil, & + smcwlt,smcref,rsmin,rc,pc,nroot,q2sat,dqsdt2, & + topt,rsmax,rgl,hs,xlai, & + rcs,rct,rcq,rcsoil,sfcems) ! --- inputs: ! ! ( nsoil, nroot, swdn, ch, q2, q2sat, dqsdt2, sfctmp, ! ! cpx1, sfcprs, sfcems, sh2o, smcwlt, smcref, zsoil, rsmin, ! @@ -869,6 +837,8 @@ subroutine gfssflx_hafs &! --- ! --- outputs: ! ! rc, pc, rcs, rct, rcq, rcsoil ) ! + else + rc = 0.0 endif !> - Now decide major pathway branch to take depending on whether @@ -881,17 +851,24 @@ subroutine gfssflx_hafs &! --- !! and heat flux values and update soil moisture contant and soil heat !! content values. call nopac -! --- inputs: ! -! ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, ! -! smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, ! -! t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, ! -! slope, kdt, frzx, psisat, zsoil, dksat, dwsat, ! -! zbot, ice, rtdis, quartz, fxexp, csoil, ! -! --- input/outputs: ! -! cmc, t1, stc, sh2o, tbot, ! -! --- outputs: ! -! eta, smc, ssoil, runoff1, runoff2, runoff3, edir, ! -! ec, et, ett, beta, drip, dew, flx1, flx3 ) ! +!................................... +! --- inputs: + & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, & + & smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, & + & t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, & + & slope, kdt, frzx, psisat, zsoil, dksat, dwsat, & + & zbot, rtdis, quartz, fxexp, csoil, & + & opt_thcnd, & +! --- input for fasdas (FDDA) (Not used for HAFS): + & qfx_phy, hcpct_fasdas, xsda_qfx, qfx_phy, xqnorm, fasdas, & +! --- input/outputs: + & cmc, t1, stc, sh2o, tbot, & + & sfhead1rt, infxs1rt, rtpnd1, & +! --- outputs: + & eta, smc, ssoil, runoff1, runoff2, runoff3, edir, & + & ec, et, ett, beta, drip, dew, flx1, flx3, & + & hcpct_fasdas & + & ) else @@ -998,15 +975,13 @@ subroutine gfssflx_hafs &! --- !----------------------------------- !>\ingroup Noah_LSM !> This subroutine calculates albedo including snow effect (0 -> 1). - subroutine alcalc (alb, snoalb, embrd, shdfac, shdmin, sncovr, & - & tsnow, albedo, sfcems, dt, snowng, snotime1, & - & lvcoef) + subroutine alcalc & !................................... ! --- inputs: -! & ( alb, snoalb, shdfac, shdmin, sncovr, tsnow, & + & ( alb, snoalb, shdfac, shdmin, sncovr, tsnow,embrd,dt,lvcoef & ! --- outputs: -! & albedo & -! & ) + & albedo, sfcems, snotime1 & + & ) ! ===================================================================== ! ! description: ! @@ -1028,6 +1003,7 @@ subroutine alcalc (alb, snoalb, embrd, shdfac, shdmin, sncovr, & ! ! ! outputs to calling program: ! ! albedo - real, surface albedo including snow effect 1 ! +! sfcems - real, sfc LW emissivity (fractional) 1 ! ! ! ! ==================== end of description ===================== ! ! @@ -1036,8 +1012,11 @@ subroutine alcalc (alb, snoalb, embrd, shdfac, shdmin, sncovr, & real (kind=kind_phys), intent(in) :: alb, snoalb, embrd, shdfac, & & shdmin, sncovr, tsnow, dt, lvcoef + logical (kind=kind_phys), intent(in) :: snowng + real (kind=kind_phys), intent(out) :: snotime1 + ! --- outputs: real (kind=kind_phys), intent(out) :: albedo, sfcems @@ -1058,7 +1037,7 @@ subroutine alcalc (alb, snoalb, embrd, shdfac, shdmin, sncovr, & ! albedo = alb + (1.0-(shdfac-shdmin))*sncovr*(snoalb-alb) albedo = alb + sncovr * (snoalb - alb) - emissi = embrd + sncovr * (emissi_s - embrd) + sfcems = embrd + sncovr * (emissi_s - embrd) ! --- base formulation (dickinson et al., 1986, cogley et al., 1990) @@ -1119,9 +1098,9 @@ subroutine alcalc (alb, snoalb, embrd, shdfac, shdmin, sncovr, & if (snowng) then snotime1 = 0. else - snotime1=snotime1+dt + snotime1=snotime1+dt ! if (tsnow.lt.273.16) then - snoalb2=snoalb1*(snacca**((snotime1/86400.0)**snaccb)) + snoalb2=snoalb1*(snacca**((snotime1/86400.0)**snaccb)) ! else ! snoalb2 ! =snoalb1*(snthwa**((snotime1/86400.0)**snthwb)) @@ -1156,7 +1135,7 @@ end subroutine alcalc subroutine canres (swdn,ch,sfctmp,q2,sfcprs,smc,zsoil,nsoil, & smcwlt,smcref,rsmin,rc,pc,nroot,q2sat,dqsdt2, & topt,rsmax,rgl,hs,xlai, & - rcs,rct,rcq,rcsoil,emissi) + rcs,rct,rcq,rcsoil,sfcems) ! --- inputs: ! & ( nsoil, nroot, swdn, ch, q2, q2sat, dqsdt2, sfctmp, & @@ -1301,7 +1280,7 @@ subroutine canres (swdn,ch,sfctmp,q2,sfcprs,smc,zsoil,nsoil, & ! evaporation (containing rc term). rc = rsmin / (xlai*rcs*rct*rcq*rcsoil) - rr = (4.0*sfcems*sigma1*rd1/cpx1) * (sfctmp**4.0)/(sfcprs*ch) + 1.0 + rr = (4.0*sfcems*sigma*rd1/cpx1) * (sfctmp**4.0)/(sfcprs*ch) + 1.0 delta = (lsubc/cpx1) * dqsdt2 pc = (rr + delta) / (rr*(1.0 + rc*ch) + delta) @@ -1315,18 +1294,18 @@ end subroutine canres !----------------------------------- !>\ingroup Noah_LSM !> This subroutine calculates snow termal conductivity - subroutine csnow (sndens, sncond) + subroutine csnow !................................... ! --- inputs: -! & ( sndens, & + & ( sndens, & ! --- outputs: -! & sncond & -! & ) - + & sncond & + & ) + ! ===================================================================== ! ! description: ! ! ! -! subroutine csnow calculates snow termal conductivity ! +! subroutine csnow calculates snow thermal conductivity ! ! ! ! subprogram called: none ! ! ! @@ -1336,10 +1315,11 @@ subroutine csnow (sndens, sncond) ! sndens - real, snow density 1 ! ! ! ! outputs to the calling program: ! -! sncond - real, snow termal conductivity 1 ! +! sncond - real, snow thermal conductivity 1 ! ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- constant parameters: real (kind=kind_phys), parameter :: unit = 0.11631 @@ -1383,17 +1363,22 @@ end subroutine csnow subroutine nopac !................................... ! --- inputs: -! & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, & -! & smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, & -! & t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, & -! & slope, kdt, frzx, psisat, zsoil, dksat, dwsat, & -! & zbot, ice, rtdis, quartz, fxexp, csoil, & + & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, & + & smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, & + & t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, & + & slope, kdt, frzx, psisat, zsoil, dksat, dwsat, & + & zbot, rtdis, quartz, fxexp, csoil, & + & opt_thcnd, & +! --- input for fasdas (FDDA) (Not used for HAFS): + & qfx_phy, hcpct_fasdas, xsda_qfx, qfx_phy, xqnorm, fasdas, & ! --- input/outputs: -! & cmc, t1, stc, sh2o, tbot, & + & cmc, t1, stc, sh2o, tbot, & + & sfhead1rt, infxs1rt, rtpnd1, & ! --- outputs: -! & eta, smc, ssoil, runoff1, runoff2, runoff3, edir, & -! & ec, et, ett, beta, drip, dew, flx1, flx3 & -! & ) + & eta, smc, ssoil, runoff1, runoff2, runoff3, edir, & + & ec, et, ett, beta, drip, dew, flx1, flx3, & + & hcpct_fasdas & + & ) ! ===================================================================== ! ! description: ! @@ -1471,24 +1456,30 @@ subroutine nopac ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- inputs: -! integer, intent(in) :: nsoil, nroot, ice + integer, intent(in) :: nsoil, nroot + integer, intent(in) :: opt_thcnd -! real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, & -! & smcwlt, smcref, smcdry, cmcmax, dt, shdfac, sbeta, & -! & sfctmp, sfcems, t24, th2, fdown, epsca, bexp, pc, & -! & rch, rr, cfactr, slope, kdt, frzx, psisat, & -! & zsoil(nsoil), dksat, dwsat, zbot, rtdis(nsoil), & -! & quartz, fxexp, csoil + real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, & + & smcwlt, smcref, smcdry, cmcmax, dt, shdfac, sbeta, & + & sfctmp, sfcems, t24, th2, fdown, epsca, bexp, pc, & + & rch, rr, cfactr, slope, kdt, frzx, psisat, & + & dksat, dwsat, zbot, quartz, fxexp, csoil + + real (kind=kind_phys), dimension(nsoil), intent(in) :: zsoil,rtdis ! --- input/outputs: -! real (kind=kind_phys), intent(inout) :: cmc, t1, stc(nsoil), & -! & sh2o(nsoil), tbot + real (kind=kind_phys), intent(inout) :: cmc, t1, tbot + real (kind=kind_phys), dimension(nsoil), intent(inout) :: stc,sh2o ! --- outputs: -! real (kind=kind_phys), intent(out) :: eta, smc(nsoil), ssoil, & -! & runoff1, runoff2, runoff3, edir, ec, et(nsoil), ett, & -! & beta, drip, dew, flx1, flx3 + real (kind=kind_phys), intent(out) :: eta, smc(nsoil), ssoil, & + & runoff1, runoff2, runoff3, edir, ec, et(nsoil), ett, & + & beta, drip, dew, flx1, flx3 + +! --- ... fasdas + real (kind=kind_phys), intent(out) :: hcpct_fasdas ! --- locals: real (kind=kind_phys) :: df1, eta1, etp1, prcp1, yy, yynum, & @@ -1496,6 +1487,11 @@ subroutine nopac integer :: k +! --- ... fasdas + real (kind=kind_phys), dimension(nsoil) :: eft, wetty + real (kind=kind_phys) :: qfx_phy, xsda_qfx, xqnorm + integer :: fasdas + ! !===> ... begin here ! @@ -1509,14 +1505,32 @@ subroutine nopac ec = 0.0 ec1 = 0.0 + +! fasdas +! + qfx_phy = 0.0 +! end fasdas + do k = 1, nsoil et (k) = 0.0 et1(k) = 0.0 + +! +! fasdas +! + wetty(k) = 1.0 +! +! end fasdas +! + enddo ett = 0.0 ett1 = 0.0 +!djg ndhms/wrf-hydro edit... + etpnd1 = 0.0 + if (etp > 0.0) then ! --- ... convert prcp from 'kg m-2 s-1' to 'm s-1'. @@ -1530,6 +1544,49 @@ subroutine nopac & eta1, edir1, ec1, et1, ett1 & & ) + +! +! fasdas +! + if( fasdas == 1 ) then + do k=1,nsoil + qfx_phy = qfx_phy + et1(k) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + if(smc(k).ge.smcref.and.xsda_qfx.gt.0.0) wetty(k)=0.0 + end do + qfx_phy = edir1+ec1+qfx_phy ! m/s + eall_now = qfx_phy ! m/s + qfx_phy = qfx_phy*1000.0 ! kg/m2/s + + if(eall_now.ne.0.0) then + efdir = (edir1/eall_now)*xsda_qfx*1.0e-03*xqnorm + efdir = efdir * wetty(1) + !twg2015 bugfix flip sign to conform to net upward flux + edir1 = edir1 + efdir ! new value + + efc = (ec1/eall_now)*xsda_qfx*1.0e-03*xqnorm + !twg2015 bugfix flip sign to conform to net upward flux + ec1 = ec1 + efc ! new value + + + do k=1,nsoil + eft(k) = (et1(k)/eall_now)*xsda_qfx*1.0e-03*xqnorm + eft(k) = eft(k) * wetty(k) + !twg2015 bugfix flip sign to conform to net upward flux + et1(k) = et1(k) + eft(k) ! new value + end do + + + end if ! for non-zero eall_now + else + qfx_phy = 0.0 + endif +! +! end fasdas +! + + + call smflx & ! --- inputs: & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & @@ -1541,18 +1598,62 @@ subroutine nopac & smc, runoff1, runoff2, runoff3, drip & & ) - else +! ---------------------------------------------------------------------- +! convert modeled evapotranspiration from m s-1 to kg m-2 s-1. +! ---------------------------------------------------------------------- -! --- ... if etp < 0, assume dew forms (transform etp1 into dew and -! reinitialize etp1 to zero). + eta = eta1 * 1000.0 - eta1 = 0.0 - dew = -etp1 +! ---------------------------------------------------------------------- +! if etp < 0, assume dew forms (transform etp1 into dew and reinitialize +! etp1 to zero). +! ---------------------------------------------------------------------- + else + dew = - etp1 ! --- ... convert prcp from 'kg m-2 s-1' to 'm s-1' and add dew amount. prcp1 = prcp1 + dew +! +! fasdas +! + if( fasdas == 1 ) then + do k=1,nsoil + qfx_phy = qfx_phy + et1(k) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + if(smc(k).ge.smcref.and.xsda_qfx.gt.0.0) wetty(k)=0.0 + end do + qfx_phy = edir1+ec1+qfx_phy ! m/s + eall_now = qfx_phy ! m/s + qfx_phy = qfx_phy*1000.0 ! kg/m2/s + + if(eall_now.ne.0.0) then + efdir = (edir1/eall_now)*xsda_qfx*1.0e-03*xqnorm + efdir = efdir * wetty(1) + !twg2015 bugfix flip sign to conform to net upward flux + edir1 = edir1 + efdir ! new value + + efc = (ec1/eall_now)*xsda_qfx*1.0e-03*xqnorm + !twg2015 bugfix flip sign to conform to net upward flux + ec1 = ec1+ efc ! new value + + do k=1,nsoil + eft(k) = (et1(k)/eall_now)*xsda_qfx*1.0e-03*xqnorm + eft(k) = eft(k) * wetty(k) + !twg2015 bugfix flip sign to conform to net upward flux + et1(k) = et1(k) + eft(k) ! new value + end do + + end if ! for non-zero eall_now + else + qfx_phy = 0.0 + endif +! +! end fasdas +! + + call smflx & ! --- inputs: & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & @@ -1566,22 +1667,11 @@ subroutine nopac endif ! end if_etp_block -! --- ... convert modeled evapotranspiration fm m s-1 to kg m-2 s-1 - - eta = eta1 * 1000.0 - edir = edir1 * 1000.0 - ec = ec1 * 1000.0 - - do k = 1, nsoil - et(k) = et1(k) * 1000.0 - enddo - - ett = ett1 * 1000.0 - ! --- ... based on etp and e values, determine beta if ( etp <= 0.0 ) then beta = 0.0 + eta = etp if ( etp < 0.0 ) then beta = 1.0 endif @@ -1589,6 +1679,18 @@ subroutine nopac beta = eta / etp endif +! --- ... convert modeled evapotranspiration fm m s-1 to kg m-2 s-1 + +! eta = eta1 * 1000.0 + edir = edir1 * 1000.0 + ec = ec1 * 1000.0 + + do k = 1, nsoil + et(k) = et1(k) * 1000.0 + enddo + + ett = ett1 * 1000.0 + ! --- ... get soil thermal diffuxivity/conductivity for top soil lyr, ! calc. adjusted top lyr soil temp and adjusted soil flux, then ! call shflx to compute/update soil heat flux and soil temps. @@ -1601,8 +1703,8 @@ subroutine nopac & ) ! if(ivegsrc == 1) then !urban -! if ( vegtyp == 13 ) df1=3.24 -! endif + if ( vegtyp == 13 ) df1=3.24 + endif ! --- ... vegetation greenness fraction reduction in subsurface heat ! flux via reduction factor, which is convenient to apply here @@ -1610,16 +1712,12 @@ subroutine nopac ! sub sfc heat flux (see additional comments on veg effect ! sub-sfc heat flx in routine sflx) !wz only urban for igbp type - if(ivegsrc == 1 .and. vegtyp == 13) then - df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) - else df1 = df1 * exp( sbeta*shdfac ) - endif ! --- ... compute intermediate terms passed to routine hrt (via routine ! shflx below) for use in computing subsurface heat flux in hrt - yynum = fdown - sfcems*sigma1*t24 + yynum = fdown - sfcems*sigma*t24 yy = sfctmp + (yynum/rch + th2 - sfctmp - beta*epsca)/rr zz1 = df1/(-0.5*zsoil(1)*rch*rr) + 1.0 @@ -1637,7 +1735,7 @@ subroutine nopac ! they are not used here in snopac. flx2 (freezing rain heat flux) ! was similarly initialized in the penman routine. - flx1 = 0.0 + flx1 = cph2o * prcp * (t1- sfctmp) flx3 = 0.0 ! return @@ -1654,11 +1752,12 @@ end subroutine nopac subroutine penman !................................... ! --- inputs: -! & ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, & -! & cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, & + & ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, & + & cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, & + & sncovr, sneqv, albedo, soldn, stc1, & ! --- outputs: -! & t24, etp, rch, epsca, rr, flx2 & -! & ) + & t24, etp, rch, epsca, rr, flx2, etpn, flx4 & + & ) ! ===================================================================== ! ! description: ! @@ -1701,49 +1800,83 @@ subroutine penman ! ==================== end of description ===================== ! ! ! --- inputs: -! real (kind=kind_phys), intent(in) :: sfctmp, sfcprs, sfcems, & -! & ch, t2v, th2, prcp, fdown, ssoil, q2, q2sat, dqsdt2 + real (kind=kind_phys), intent(in) :: sfctmp, sfcprs, sfcems, & + & ch, t2v, th2, prcp, fdown, ssoil, q2, q2sat, dqsdt2 + + real (kind=kind_phys), intent(in) :: sncovr, aoasis, albedo & + real (kind=kind_phys), intent(in) :: fvb, gama, stc1 & -! logical, intent(in) :: snowng, frzgra + logical, intent(in) :: snowng, frzgra, ua_phys ! --- outputs: -! real (kind=kind_phys), intent(out) :: t24, etp, rch, epsca, & -! & rr, flx2 + real (kind=kind_phys), intent(out) :: t24, etp, rch, epsca, & + & rr, flx2, etpn, flx4 ! --- locals: real (kind=kind_phys) :: a, delta, fnet, rad, rho + real (kind=kind_phys) :: elcp1, lvs + +! --- parameters: + real (kind=kind_phys) parameter :: elcp = 2.4888e+3, lsubc = & + & 2.501000e+6,cp = 1004.6 + real (kind=kind_phys) parameter :: lsubs = 2.83e+6 & + real (kind=kind_phys) parameter :: algdsn = 0.5, alvgsn = 0.13 & ! !===> ... begin here ! - flx2 = 0.0 + elcp1 = (1.0-sncovr)*elcp + sncovr*elcp*lsubs/lsubc + lvs = (1.0-sncovr)*lsubc + sncovr*lsubs -! --- ... prepare partial quantities for penman equation. + flx2 = 0.0 -!MKB delta = elcp * cpfac * dqsdt2 -!MKB in hwrf - delta = elcp * dqsdt2 + delta = elcp1 * dqsdt2 t24 = sfctmp * sfctmp * sfctmp * sfctmp -!MKB rr = t24 * 6.48e-8 / (sfcprs*ch) + 1.0 -!MKB rr in hwrf (sfcems is emissi in hwrf) rr = sfcems * t24 * 6.48e-8 / (sfcprs*ch) + 1.0 rho = sfcprs / (rd1*t2v) - rch = rho * cpx * ch + rch = rho * cp * ch ! --- ... adjust the partial sums / products with the latent heat ! effects caused by falling precipitation. if (.not. snowng) then - if (prcp > 0.0) rr = rr + cph2o1*prcp/rch + if (prcp > 0.0) rr = rr + cph2o*prcp/rch else -! ---- ... fractional snowfall/rainfall -!MKB rr = rr + (cpice*ffrozp+cph2o1*(1.-ffrozp)) & -!MKB in hwrf rr = rr + cpice & & *prcp/rch endif - fnet = fdown - sfcems*sigma1*t24 - ssoil + fnet = fdown - sfcems*sigma*t24 - ssoil + + + flx4 = 0.0 + if(ua_phys) then + if(sneqv > 0. .and. fnet > 0. .and. soldn > 0. ) then +! solar radiation absorbed by vegetated fraction + totabs = (1.-albedo)*soldn*fvb ! solar radiation absorbed + ucabs = min(totabs,((1.0-algdsn)*(1.0-alvgsn)*soldn*gama)*fvb) + +! print*,'penman',ucabs,totabs,soldn,gama,fvb +! ucabs -> solar radiation absorbed under canopy +! ucabs = min(totabs,(0.44*soldn*gama)*fvb) + flx4 = min(totabs - ucabs, min(250., 0.5*(1.-albedo)*soldn)) + endif + + signck = (stc1-273.15)*(sfctmp-273.15) + + if(flx4 > 0. .and. (signck <= 0. .or. stc1 < 273.15)) then + if(fnet >= flx4) then + fnetn = fnet - flx4 + else + flx4 = fnet + fnetn = 0. + endif + else + flx4 = 0.0 + fnetn = 0. + endif + endif + ! --- ... include the latent heat effects of frzng rain converting to ice ! on impact in the calculation of flx2 and fnet. @@ -1753,16 +1886,22 @@ subroutine penman fnet = fnet - flx2 endif + if(ua_phys) fnetn = fnetn - flx2 +! ---------------------------------------------------------------------- +! finish penman equation calculations. +! ---------------------------------------------------------------------- + endif + + ! --- ... finish penman equation calculations. rad = fnet/rch + th2 - sfctmp - a = elcp * cpfac * (q2sat - q2) + a = elcp * (q2sat - q2) epsca = (a*rr + rad*delta) / (delta + rr) -!MKB for hwrf ! Fei-Mike if (epsca > 0.) epsca = epsca * aoasis etp = epsca * rch /lvs -!MKB etp = epsca * rch / lsubc +! etp = epsca * rch / lsubc if (ua_phys) then radn = fnetn / rch + th2 - sfctmp @@ -1784,14 +1923,16 @@ end subroutine penman subroutine redprm !................................... ! --- inputs: -! & ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, & -! --- outputs: -! & cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, & -! & sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, & -! & snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, & -! & smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, & -! & z0, czil, xlai, csoil & -! & ) + & ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, & +! --- outputs + & cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, & + & sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, & + & snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, & + & smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, & + & czil, xlai, csoil, lvcoef, laimin, laimax, & + & emissmin, emissmax, albedomin, albedomax, z0min, z0max, & + & ztopv, zbotv + & ) ! ===================================================================== ! ! description: ! @@ -1952,24 +2093,42 @@ subroutine redprm ! czil - real, param to cal roughness length of heat 1 ! ! xlai - real, leaf area index 1 ! ! csoil - real, soil heat capacity (j m-3 k-1) 1 ! +! laimin - real, Min leaf area index through the year [no dims] ! +! laimax - real, Max leaf area index through the year [no dims] ! +! emissmin - real, Min backgrd emissivity through the year[fraction]! +! emissmax - real, Max backgrd emissivity through the year[fraction]! +! albedomin- real, Min backgrd albedo through the year[fraction] ! +! albedomax- real, Max backgrd albedo through the year[fraction] ! +! z0min - real, Min bkgd roughness len through the year [m] ! +! z0max - real, Max bkgd roughness len through the year [m] ! +! lvcoef - real, user defined coefficient for adjusting snow albe ! ! ! ! ==================== end of description ===================== ! ! use namelist_soilveg + implicit none + ! --- input: -! integer, intent(in) :: nsoil, vegtyp, soiltyp, slopetyp + integer, intent(in) :: nsoil, vegtyp, soiltyp, slopetyp -! real (kind=kind_phys), intent(in) :: sldpth(nsoil), zsoil(nsoil) + real (kind=kind_phys), intent(in) :: sldpth(nsoil), zsoil(nsoil) ! --- outputs: -! real (kind=kind_phys), intent(out) :: cfactr, cmcmax, rsmin, & -! & rsmax, topt, refkdt, kdt, sbeta, shdfac, rgl, hs, zbot, & -! & frzx, psisat, slope, snup, salp, bexp, dksat, dwsat, & -! & smcmax, smcwlt, smcref, smcdry, f1, quartz, fxexp, z0, & -! & czil, xlai, csoil, rtdis(nsoil) + real (kind=kind_phys), intent(out) :: cfactr, cmcmax, rsmin, & + & rsmax, topt, refkdt, kdt, sbeta, shdfac, rgl, hs, zbot, & + & frzx, psisat, slope, snup, salp, bexp, dksat, dwsat, & + & smcmax, smcwlt, smcref, smcdry, f1, quartz, fxexp, & + & czil, xlai, csoil, rtdis(nsoil), lvcoef, laimin, laimax, & + & emissmin, emissmax, albedomin, albedomax, z0min, z0max, & + & ztopv, zbotv + + integer, intent(out) :: nroot +! --- ...parameters: + integer, parameter :: max_slopetyp=30,max_soiltyp=30,max_vegtyp=30 -! integer, intent(out) :: nroot +! --- ...logical: + logical :: local ! --- locals: real (kind=kind_phys) :: frzfact, frzk, refdk @@ -1995,22 +2154,21 @@ subroutine redprm stop 333 endif + ! --- ... set-up universal parameters (not dependent on soiltyp, vegtyp ! or slopetyp) zbot = zbot_data salp = salp_data - cfactr = cfactr_data - cmcmax = cmcmax_data sbeta = sbeta_data - rsmax = rsmax_data - topt = topt_data refdk = refdk_data frzk = frzk_data fxexp = fxexp_data refkdt = refkdt_data czil = czil_data csoil = csoil_data + kdt = refkdt * dksat / refdk + lvcoef = lvcoef_data ! --- ... set-up soil parameters @@ -2018,37 +2176,50 @@ subroutine redprm dksat = satdk(soiltyp) dwsat = satdw(soiltyp) f1 = f11 (soiltyp) - kdt = refkdt * dksat / refdk - psisat = satpsi(soiltyp) quartz = qtz (soiltyp) smcdry = drysmc(soiltyp) smcmax = maxsmc(soiltyp) smcref = refsmc(soiltyp) smcwlt = wltsmc(soiltyp) + slope = slope_data(slopetyp) frzfact = (smcmax / smcref) * (0.412 / 0.468) ! --- ... to adjust frzk parameter to actual soil type: frzk * frzfact + frzfact = (smcmax / smcref) * (0.412 / 0.468) frzx = frzk * frzfact ! --- ... set-up vegetation parameters - nroot = nroot_data(vegtyp) - snup = snupx(vegtyp) - rsmin = rsmtbl(vegtyp) - - rgl = rgltbl(vegtyp) - hs = hstbl(vegtyp) + topt = topt_data + cmcmax = cmcmax_data + cfactr = cfactr_data + rsmax = rsmax_data + nroot = nroot_data(vegtyp) + snup = snupx(vegtyp) + rsmin = rsmtbl(vegtyp) + rgl = rgltbl(vegtyp) + hs = hstbl(vegtyp) ! roughness lengthe is defined in sfcsub ! z0 = z0_data(vegtyp) xlai= lai_data(vegtyp) + emissmin = emissmintbl (vegtyp) + emissmax = emissmaxtbl (vegtyp) + laimin = laimintbl (vegtyp) + laimax = laimaxtbl (vegtyp) + z0min = z0mintbl (vegtyp) + z0max = z0maxtbl (vegtyp) + albedomin = albedomintbl (vegtyp) + albedomax = albedomaxtbl (vegtyp) + ztopv = ztopvtbl (vegtyp) + zbotv = zbotvtbl (vegtyp) if (vegtyp == bare) shdfac = 0.0 if (nroot > nsoil) then - write(*,*) 'warning: too many root layers' + write(*,*) 'warning: too many root layers', nsoil, nroot stop 333 endif @@ -2360,15 +2531,14 @@ end subroutine sfcdif !----------------------------------- !>\ingroup Noah_LSM !> This subroutine calculates snow fraction (0->1). - subroutine snfrac (sneqv,snup,salp,snowh,sncovr, & - xlai,shdfac,fvb,gama,fbur, & - fgsn,ztopv,zbotv,ua_phys) + subroutine snfrac & !................................... ! --- inputs: -! & ( sneqv, snup, salp, snowh, & + & ( sneqv, snup, salp, snowh, & + & ztopv, zbotv, shdfac, xlai, shdfac, ua_phys & ! --- outputs: -! & sncovr & -! & ) + & sncovr, fvb, gama, fbur, fgsn & + & ) ! ===================================================================== ! ! description: ! @@ -2398,7 +2568,6 @@ subroutine snfrac (sneqv,snup,salp,snowh,sncovr, & real (kind=kind_phys), intent(in) :: ztopv ! ua: height of canopy top real (kind=kind_phys), intent(in) :: zbotv ! ua: height of canopy bottom real (kind=kind_phys), intent(in) :: shdfac ! ua: vegetation fraction - real (kind=kind_phys), intent(in) :: ztopv ! flag for ua option real (kind=kind_phys), intent(inout) :: xlai ! ua: lai modified by snow @@ -2505,18 +2674,23 @@ end subroutine snfrac subroutine snopac !................................... ! --- inputs: -! & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, & -! & cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, & -! & bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, & -! & zsoil, dwsat, dksat, zbot, shdfac, ice, rtdis, quartz, & -! & fxexp, csoil, flx2, snowng, & + & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, & + & cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, & + & bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, & + & zsoil, dwsat, dksat, zbot, shdfac, rtdis, quartz, & + & fxexp, csoil, flx2, snowng, & + & opt_thcnd, & +! --- input for fasdas (FDDA) (Not used for HAFS): + & qfx_phy, hcpct_fasdas, qfx_phy, fasdas, & ! --- input/outputs: -! & prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, & -! & sh2o, tbot, beta, & + & prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, & + & sh2o, tbot, beta, & + & sfhead1rt, infxs1rt, rtpnd1, & ! --- outputs: -! & smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, & -! & ett, snomlt, drip, dew, flx1, flx3, esnow & -! & ) + & smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, & + & ett, snomlt, drip, dew, flx1, flx3, esnow, etns & + & hcpct_fasdas & + & ) ! ===================================================================== ! ! description: ! @@ -2606,33 +2780,38 @@ subroutine snopac real, parameter :: esdmin = 1.e-6 ! --- inputs: -! integer, intent(in) :: nsoil, nroot, ice + integer, intent(in) :: nsoil, nroot, ice -! real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, smcref, & -! & smcwlt, smcdry, cmcmax, dt, df1, sfcems, sfctmp, t24, & -! & th2, fdown, epsca, bexp, pc, rch, rr, cfactr, slope, kdt, & -! & frzx, psisat, dwsat, dksat, zbot, shdfac, quartz, & -! & csoil, fxexp, flx2, zsoil(nsoil), rtdis(nsoil) + real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, smcref, & + & smcwlt, smcdry, cmcmax, dt, df1, sfcems, sfctmp, t24, & + & th2, fdown, epsca, bexp, pc, rch, rr, cfactr, slope, kdt, & + & frzx, psisat, dwsat, dksat, zbot, shdfac, quartz, & + & csoil, fxexp, flx2, zsoil(nsoil), rtdis(nsoil) -! logical, intent(in) :: snowng + logical, intent(in) :: snowng ! --- input/outputs: -! real (kind=kind_phys), intent(inout) :: prcp1, t1, sncovr, sneqv, & -! & sndens, snowh, cmc, tbot, beta, sh2o(nsoil), stc(nsoil) + real (kind=kind_phys), intent(inout) :: prcp1, t1, sncovr, sneqv, & + & sndens, snowh, cmc, tbot, beta, sh2o(nsoil), stc(nsoil) ! --- outputs: -! real (kind=kind_phys), intent(out) :: ssoil, runoff1, runoff2, & -! & runoff3, edir, ec, et(nsoil), ett, snomlt, drip, dew, & -! & flx1, flx3, esnow, smc(nsoil) + real (kind=kind_phys), intent(out) :: ssoil, runoff1, runoff2, & + & runoff3, edir, ec, et(nsoil), ett, snomlt, drip, dew, & + & flx1, flx3, esnow, smc(nsoil), etns ! --- locals: real (kind=kind_phys):: denom, dsoil, dtot, etp1, ssoil1, & & snoexp, ex, t11, t12, t12a, t12b, yy, zz1, seh, t14, & - & ec1, edir1, ett1, etns, etns1, esnow1, esnow2, etanrg, & + & ec1, edir1, ett1, etns1, esnow1, esnow2, etanrg, & & et1(nsoil) integer k +! --- ... fasdas + real (kind=kind_phys), dimension(nsoil) :: eft, wetty + real (kind=kind_phys) :: qfx_phy, xsda_qfx, xqnorm + integer :: fasdas + ! data snoexp /1.0/ !!! <----- for noah v2.7 data snoexp /2.0/ !!! <----- for noah v2.7.1 @@ -3027,10 +3206,10 @@ end subroutine snopac subroutine snow_new !................................... ! --- inputs: -! & ( sfctmp, sn_new, & + & ( sfctmp, sn_new, & ! --- input/outputs: -! & snowh, sndens & -! & ) + & snowh, sndens & + & ) ! ===================================================================== ! ! description: ! @@ -3053,11 +3232,12 @@ subroutine snow_new ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- inputs: -! real(kind=kind_phys), intent(in) :: sfctmp, sn_new + real(kind=kind_phys), intent(in) :: sfctmp, sn_new ! --- input/outputs: -! real(kind=kind_phys), intent(inout) :: snowh, sndens + real(kind=kind_phys), intent(inout) :: snowh, sndens ! --- locals: real(kind=kind_phys) :: dsnew, snowhc, hnewc, newsnc, tempc @@ -3085,7 +3265,11 @@ subroutine snow_new ! --- ... adjustment of snow density depending on new snowfall hnewc = newsnc / dsnew - sndens = (snowhc*sndens + hnewc*dsnew) / (snowhc + hnewc) + if (snowhc + hnewc < 1.0e-3) then + sndens = max(dsnew,sndens) + else + sndens = (snowhc * sndens + hnewc * dsnew)/ (snowhc + hnewc) + endif snowhc = snowhc + hnewc snowh = snowhc * 0.01 ! @@ -3101,9 +3285,9 @@ end subroutine snow_new subroutine snowz0 !................................... ! --- inputs: -! & ( sncovr, & + & ( sncovr,z0brd,snowh,fbur,fgsn,shdmax,ua_phys, & ! --- input/outputs: -! & z0 & + & z0 & ! & ) ! ===================================================================== ! @@ -3124,21 +3308,43 @@ subroutine snowz0 ! ==================== end of description ===================== ! ! ! --- inputs: -! real(kind=kind_phys), intent(in) :: sncovr - -! --- input/outputs: -! real(kind=kind_phys), intent(inout) :: z0 + real(kind=kind_phys), intent(in) :: sncovr, z0brd, snowh, fbur + real(kind=kind_phys), intent(in) :: fgsn, shdmax, snowh -! --- locals: - real(kind=kind_phys) :: z0s +! --- outputs: + real(kind=kind_phys), intent(out) :: z0 + +! --- logical: + logical :: ua_phys +! --- parameters: + real(kind=kind_phys), parameter :: z0s = 0.001, z0g = 0.01 +! --- locals: + real (kind_phys) :: burial, z0eff, fv, a1, a2 ! !===> ... begin here ! -! z0s = 0.001 ! snow roughness length:=0.001 (m) -! --- ... current noah lsm condition - mbek, 09-oct-2001 - z0s = z0 - z0 = (1.0 - sncovr)*z0 + sncovr*z0s + if(ua_phys) then + + fv = shdmax * (1.-fbur) + a1 = (1.-fv)**2*((1.-fgsn**2)*log(z0g) + (fgsn**2)*log(z0s)) + a2 = (1.-(1.-fv)**2)*log(z0brd) + z0 = exp(a1+a2) + + else + +!m z0 = (1.- sncovr)* z0brd + sncovr * z0s + burial = 7.0*z0brd - snowh + if(burial.le.0.0007) then + z0eff = z0s + else + z0eff = burial/7.0 + endif + + z0 = (1.- sncovr)* z0brd + sncovr * z0eff + + endif + ! return @@ -3153,7 +3359,7 @@ end subroutine snowz0 !! of the soil for a given point and time. subroutine tdfcnd & ! --- inputs: - & ( smc, qz, smcmax, sh2o, & + & ( smc, qz, smcmax, sh2o, bexp, psisat, soiltyp, opt_thcnd, & ! --- outputs: & df & & ) @@ -3188,6 +3394,10 @@ subroutine tdfcnd & ! qz - real, quartz content (soil type dependent) 1 ! ! smcmax - real, porosity 1 ! ! sh2o - real, top layer unfrozen soil moisture 1 ! +! bexp - real, soil type "b" parameter 1 ! +! psisat - real, saturated soil potential 1 ! +! soiltyp - integer, soil type 1 ! +! opt_thcnd- integer, option to treat thermal conductivity 1 ! ! ! ! outputs: ! ! df - real, soil thermal diffusivity and conductivity 1 ! @@ -3202,6 +3412,7 @@ subroutine tdfcnd & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- input: real (kind=kind_phys), intent(in) :: smc, qz, smcmax, sh2o @@ -3210,75 +3421,99 @@ subroutine tdfcnd & ! --- locals: real (kind=kind_phys) :: gammd, thkdry, ake, thkice, thko, & - & thkqtz, thksat, thks, thkw, satratio, xu, xunfroz + & thkqtz, thksat, thks, thkw, satratio, xu, xunfroz, & + & akei, akel, psif, pf ! !===> ... begin here ! ! --- ... if the soil has any moisture content compute a partial sum/product ! otherwise use a constant value which works well with most soils + if ( opt_thcnd == 1 .or. ( opt_thcnd == 2 .and. (soiltyp /= 4 & + & .and. soiltyp /= 3)) )then ! --- ... saturation ratio: +! --- ... parameters w/(m.k) - satratio = smc / smcmax + satratio = smc / smcmax -! --- ... parameters w/(m.k) - thkice = 2.2 - thkw = 0.57 - thko = 2.0 +! --- ... ice conductivity + thkice = 2.2 + +! --- ... water conductivity + thkw = 0.57 +! --- ... thermal conductivity of "other" soil components + thko = 2.0 ! if (qz <= 0.2) thko = 3.0 - thkqtz = 7.7 + +! --- ... quartz conductivity + thkqtz = 7.7 ! --- ... solids' conductivity - thks = (thkqtz**qz) * (thko**(1.0-qz)) + thks = (thkqtz**qz) * (thko**(1.0-qz)) ! --- ... unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen)) - xunfroz = (sh2o + 1.e-9) / (smc + 1.e-9) + xunfroz = (sh2o) / (smc) ! --- ... unfrozen volume for saturation (porosity*xunfroz) - xu=xunfroz*smcmax + xu=xunfroz*smcmax ! --- ... saturated thermal conductivity - thksat = thks**(1.-smcmax) * thkice**(smcmax-xu) * thkw**(xu) + thksat = thks**(1.-smcmax) * thkice**(smcmax-xu) * thkw**(xu) ! --- ... dry density in kg/m3 - gammd = (1.0 - smcmax) * 2700.0 + gammd = (1.0 - smcmax) * 2700.0 ! --- ... dry thermal conductivity in w.m-1.k-1 - thkdry = (0.135*gammd + 64.7) / (2700.0 - 0.947*gammd) - - if ( sh2o+0.0005 < smc ) then ! frozen + thkdry = (0.135*gammd + 64.7) / (2700.0 - 0.947*gammd) - ake = satratio +! --- ... frozen + akei = satratio - else ! unfrozen +! --- ... unfrozen ! --- ... range of validity for the kersten number (ake) - if ( satratio > 0.1 ) then + if ( satratio > 0.1 ) then ! --- ... kersten number (using "fine" formula, valid for soils containing ! at least 5% of particles with diameter less than 2.e-6 meters.) ! (for "coarse" formula, see peters-lidard et al., 1998). - ake = log10( satratio ) + 1.0 + akel = log10( satratio ) + 1.0 - else + else ! --- ... use k = kdry - ake = 0.0 + akel = 0.0 - endif ! end if_satratio_block - - endif ! end if_sh2o+0.0005_block + endif ! end if_satratio_block + + ake = ((smc-sh2o)*akei + sh2o*akel)/smc ! --- ... thermal conductivity - df = ake * (thksat - thkdry) + thkdry + df = ake * (thksat - thkdry) + thkdry + + else ! opt_thcnd + +! --- ... use the mccumber and pielke approach for silt loam (4), sandy loam (3) + + psif = psisat*100.*(smcmax/(smc))**bexp +! --- ... psif should be in [cm] to compute pf + pf=log10(abs(psif)) +! --- ... hk is for mccumber thermal conductivity + if(pf.le.5.1) then + df=420.*exp(-(pf+2.7)) + else + df=.1744 + end if + + endif ! for opt_thcnd options ! return !................................... @@ -4902,6 +5137,7 @@ subroutine rosr12 & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- inputs: integer, intent(in) :: nsoil @@ -5154,6 +5390,7 @@ subroutine srt & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- inputs: integer, intent(in) :: nsoil @@ -5286,7 +5523,7 @@ subroutine srt & & ) infmax = max( infmax, wcnd ) - infmax = min( infmax, px ) + infmax = min( infmax, px/dt ) if (pcpdrp > infmax) then runoff1 = pcpdrp - infmax @@ -5449,9 +5686,9 @@ subroutine sstep & ! input/outputs: ! ! cmc - real, canopy moisture content 1 ! ! rhstt - real, soil water time tendency nsoil ! -! ai - real, matrix coefficients nsold ! -! bi - real, matrix coefficients nsold ! -! ci - real, matrix coefficients nsold ! +! ai - real, matrix coefficients nsoil ! +! bi - real, matrix coefficients nsoil ! +! ci - real, matrix coefficients nsoil ! ! ! ! outputs: ! ! sh2oout - real, updated soil moisture content nsoil ! @@ -5460,6 +5697,7 @@ subroutine sstep & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- input: integer, intent(in) :: nsoil @@ -5470,7 +5708,7 @@ subroutine sstep & ! --- inout/outputs: real (kind=kind_phys), intent(inout) :: cmc, rhstt(nsoil), & - & ai(nsold), bi(nsold), ci(nsold) + & ai(nsoil), bi(nsoil), ci(nsoil) ! --- outputs: real (kind=kind_phys), intent(out) :: sh2oout(nsoil), runoff3, & @@ -5500,7 +5738,7 @@ subroutine sstep & rhsttin(k) = rhstt(k) enddo - do k = 1, nsold + do k = 1, nsoil ciin(k) = ci(k) enddo @@ -5595,6 +5833,7 @@ subroutine tbnd & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- input: integer, intent(in) :: k, nsoil @@ -5673,6 +5912,7 @@ subroutine tmpavg & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- input: integer, intent(in) :: nsoil, k @@ -5682,7 +5922,8 @@ subroutine tmpavg & real (kind=kind_phys), intent(out) :: tavg ! --- locals: - real (kind=kind_phys) :: dz, dzh, x0, xdn, xup + real (kind=kind_phys) :: dz, dzh, x0, xdn, xup, t0 + ! !===> ... begin here ! @@ -5782,6 +6023,7 @@ subroutine transp & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- input: integer, intent(in) :: nsoil, nroot @@ -5910,6 +6152,7 @@ subroutine wdfcnd & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- input: real (kind=kind_phys), intent(in) :: smc, smcmax, bexp, dksat, & & dwsat, sicemax @@ -5924,8 +6167,9 @@ subroutine wdfcnd & ! ! --- ... calc the ratio of the actual to the max psbl soil h2o content - factr1 = min(1.0, max(0.0, 0.2/smcmax)) - factr2 = min(1.0, max(0.0, smc/smcmax)) + factr1 = 0.05 / smcmax + factr2 = smc / smcmax + factr1 = min(factr1,factr2) ! --- ... prep an expntl coef and calc the soil water diffusivity @@ -5963,6 +6207,6 @@ end subroutine wdfcnd ! =========================== ! !................................... - end subroutine gfssflx + end subroutine gfssflx_hafs !! @} !----------------------------------- From 23ca1283ba2ce84a46ed99922951c443725f5e1a Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Sat, 25 Jan 2020 17:36:09 +0000 Subject: [PATCH 06/16] Updating Noah for HAFS --- physics/sflx_hafs.f | 117 ++++++++++++++++++++++++++++++-------------- 1 file changed, 80 insertions(+), 37 deletions(-) diff --git a/physics/sflx_hafs.f b/physics/sflx_hafs.f index e45a21177..162e7ce1f 100644 --- a/physics/sflx_hafs.f +++ b/physics/sflx_hafs.f @@ -1473,6 +1473,9 @@ subroutine nopac real (kind=kind_phys), intent(inout) :: cmc, t1, tbot real (kind=kind_phys), dimension(nsoil), intent(inout) :: stc,sh2o +!djg ndhms/wrf-hydro edit... + real (kind=kind_phys), intent(inout) :: sfhead1rt,infxs1rt,etpnd1 + ! --- outputs: real (kind=kind_phys), intent(out) :: eta, smc(nsoil), ssoil, & & runoff1, runoff2, runoff3, edir, ec, et(nsoil), ett, & @@ -2682,9 +2685,11 @@ subroutine snopac & opt_thcnd, & ! --- input for fasdas (FDDA) (Not used for HAFS): & qfx_phy, hcpct_fasdas, qfx_phy, fasdas, & +! --- input/inout for ua_phys: + & ua_phys, etpn, etpnd1, etp1n, flx4, & ! --- input/outputs: & prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, & - & sh2o, tbot, beta, & + & sh2o, tbot, beta, ribb, & & sfhead1rt, infxs1rt, rtpnd1, & ! --- outputs: & smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, & @@ -2777,22 +2782,35 @@ subroutine snopac ! ==================== end of description ===================== ! ! ! --- constant parameters: - real, parameter :: esdmin = 1.e-6 + real, parameter :: esdmin = 1.e-6, lsubc = 2.501000e+6, & + & lsubs = 2.83e+6, snoexp = 2.0 ! --- inputs: - integer, intent(in) :: nsoil, nroot, ice + integer, intent(in) :: nsoil, nroot, ice, ua_phys real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, smcref, & & smcwlt, smcdry, cmcmax, dt, df1, sfcems, sfctmp, t24, & & th2, fdown, epsca, bexp, pc, rch, rr, cfactr, slope, kdt, & & frzx, psisat, dwsat, dksat, zbot, shdfac, quartz, & - & csoil, fxexp, flx2, zsoil(nsoil), rtdis(nsoil) - + & opt_thcnd, csoil, fxexp, flx2, zsoil(nsoil), rtdis(nsoil) + logical, intent(in) :: snowng +! ---- ... ua_phys + real (kind=kind_phys), intent(inout) :: etpn + ! --- input/outputs: real (kind=kind_phys), intent(inout) :: prcp1, t1, sncovr, sneqv, & - & sndens, snowh, cmc, tbot, beta, sh2o(nsoil), stc(nsoil) + & sndens, snowh, cmc, tbot, beta, sh2o(nsoil), stc(nsoil), & + & esd, ribb, qsat + +!djg ndhms/wrf-hydro edit... + real (kind=kind_phys), intent(inout) :: sfhead1rt, infxs1rt, & + & etpnd1 + +! ---- ... ua_phys + real (kind=kind_phys), intent(inout) :: flx4 + ! --- outputs: real (kind=kind_phys), intent(out) :: ssoil, runoff1, runoff2, & @@ -2800,20 +2818,21 @@ subroutine snopac & flx1, flx3, esnow, smc(nsoil), etns ! --- locals: - real (kind=kind_phys):: denom, dsoil, dtot, etp1, ssoil1, & + real (kind=kind_phys):: denom, dsoil, dtot, etp1,etp2,etp3,ssoil1,& & snoexp, ex, t11, t12, t12a, t12b, yy, zz1, seh, t14, & - & ec1, edir1, ett1, etns1, esnow1, esnow2, etanrg, & - & et1(nsoil) + & ec1, edir1, ett1, etns1, esnow1, esnow2, etanrg, rsnow, & + & et1(nsoil), sncond + +! ---- ... ua_phys + real (kind=kind_phys) :: etp1n - integer k + integer :: k ! --- ... fasdas real (kind=kind_phys), dimension(nsoil) :: eft, wetty - real (kind=kind_phys) :: qfx_phy, xsda_qfx, xqnorm + real (kind=kind_phys) :: qfx_phy, hcpct_fasdas integer :: fasdas -! data snoexp /1.0/ !!! <----- for noah v2.7 - data snoexp /2.0/ !!! <----- for noah v2.7.1 ! --- ... convert potential evap (etp) from kg m-2 s-1 to m s-1 and then to an ! amount (m) given timestep (dt) and call it an effective snowpack @@ -2832,6 +2851,7 @@ subroutine snopac prcp1 = prcp1 * 0.001 + dew = 0.0 edir = 0.0 edir1 = 0.0 @@ -2851,29 +2871,34 @@ subroutine snopac esnow1= 0.0 esnow2= 0.0 - dew = 0.0 etp1 = etp * 0.001 - if (etp < 0.0) then +!djg ndhms/wrf-hydro edit... + etpnd1 = 0.0 -! --- ... if etp<0 (downward) then dewfall (=frostfall in this case). +! ---------------------------------------------------------------------- +! if etp<0 (downward) then dewfall (=frostfall in this case). +! ---------------------------------------------------------------------- + beta = 1.0 - dew = -etp1 - esnow2 = etp1 * dt - etanrg = etp * ((1.0-sncovr)*lsubc + sncovr*lsubs) + if (etp < 0.0) then +! --- ... if etp<0 (downward) then dewfall (=frostfall in this case). + if ( ( ribb >= 0.1 ) .and. ( fdown > 150.0 ) ) then + etp=(min(etp*(1.0-ribb),0.)*sncovr/0.980 + & + & etp*(0.980-sncovr))/0.980 + endif + if(etp == 0.) beta = 0.0 + etp1 = etp * 0.001 + if(ua_phys) etp1n = etpn * 0.001 + dew = -etp1 + esnow2 = etp1*dt + etanrg = etp*((1.-sncovr)*lsubc + sncovr*lsubs) else + etp1 = etp * 0.001 + if(ua_phys) etp1n = etpn * 0.001 -! --- ... etp >= 0, upward moisture flux - - if (ice /= 0) then ! for sea-ice and glacial-ice case - - esnow = etp - esnow1 = esnow * 0.001 - esnow2 = esnow1 * dt - etanrg = esnow * lsubs - - else ! for non-glacial land case + ! land case if (sncovr < 1.0) then @@ -2903,19 +2928,35 @@ subroutine snopac et(k) = et1(k) * 1000.0 enddo +! +! fasdas +! + if( fasdas == 1 ) then + qfx_phy = edir + ec + do k=1,nsoil + qfx_phy = qfx_phy + et(k) + end do + endif +! +! end fasdas +! + ett = ett1 * 1000.0 etns = etns1 * 1000.0 +!djg ndhms/wrf-hydro edit... + etpnd1 = etpnd1*1000. + + endif ! end if_sncovr_block esnow = etp * sncovr ! esnow1 = etp * 0.001 + if(ua_phys) esnow = etpn*sncovr ! use adjusted etp esnow1 = esnow * 0.001 esnow2 = esnow1 * dt etanrg = esnow*lsubs + etns*lsubc - endif ! end if_ice_block - endif ! end if_etp_block ! --- ... if precip is falling, calculate heat flux from snow sfc to newly @@ -2926,10 +2967,9 @@ subroutine snopac flx1 = 0.0 if ( snowng ) then ! --- ... fractional snowfall/rainfall - flx1 = (cpice* ffrozp + cph2o1*(1.-ffrozp)) & - & * prcp * (t1 - sfctmp) + flx1 = cpice * prcp * (t1- sfctmp) else - if (prcp > 0.0) flx1 = cph2o1 * prcp * (t1 - sfctmp) + if (prcp > 0.0) flx1 = cph2o * prcp * (t1 - sfctmp) endif ! --- ... calculate an 'effective snow-grnd sfc temp' (t12) based on heat @@ -2945,7 +2985,7 @@ subroutine snopac ! t12a = ( (fdown - flx1 - flx2 - sigma1*t24) / rch & ! & + th2 - sfctmp - beta*epsca ) / rr - t12a = ( (fdown - flx1 - flx2 - sfcems*sigma1*t24) / rch & + t12a = ( (fdown - flx1 - flx2 - sfcems*sigma*t24) / rch & & + th2 - sfctmp - etanrg/rch ) / rr t12b = df1 * stc(1) / (dtot * rr * rch) @@ -2970,8 +3010,11 @@ subroutine snopac ex = 0.0 snomlt = 0.0 + if(ua_phys) flx4 = 0.0 + else + ! --- ... if the 'effective snow-grnd sfc temp' is above freezing, snow melt ! will occur. call the snow melt rate,ex and amt, snomlt. revise the ! effective snow depth. revise the skin temp because it would have chgd @@ -2990,8 +3033,8 @@ subroutine snopac ! for the linear case (snoexp = 1). ! t1 = tfreez * sncovr**snoexp + t12 * (1.0 - sncovr**snoexp) - t1 = tfreez * max(0.01,sncovr**snoexp) + & - & t12 * (1.0 - max(0.01,sncovr**snoexp)) + t1 = tfreez * max(0.01,sncovr**snoexp) + & + & t12 * (1.0 - max(0.01,sncovr**snoexp)) beta = 1.0 ssoil = df1 * (t1 - stc(1)) / dtot From 2e1768e54c3a81fcf09461f2472ad5ddbdb530ed Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Sun, 26 Jan 2020 20:02:15 +0000 Subject: [PATCH 07/16] Updates to Noal lsm to make it CCPP complaiant for HAFS --- physics/sflx_hafs.f | 355 ++++++++++++++++++++++++++++---------------- 1 file changed, 223 insertions(+), 132 deletions(-) diff --git a/physics/sflx_hafs.f b/physics/sflx_hafs.f index 162e7ce1f..2d4ab1059 100644 --- a/physics/sflx_hafs.f +++ b/physics/sflx_hafs.f @@ -290,14 +290,14 @@ subroutine gfssflx_hafs &! --- ! real (kind=kind_phys), parameter :: gs = con_g !< con_g =9.80665 real (kind=kind_phys), parameter :: gs1 = 9.8 !< con_g in sfcdif - real (kind=kind_phys), parameter :: gs2 = 9.81 !< con_g in snowpack, frh2o + real (kind=kind_phys), parameter :: gs = 9.81 !< con_g in snowpack, frh2o real (kind=kind_phys), parameter :: tfreez = con_t0c !< con_t0c =273.16 real (kind=kind_phys), parameter :: lsubc = 2.501e+6 !< con_hvap=2.5000e+6 real (kind=kind_phys), parameter :: lsubf = 3.335e5 !< con_hfus=3.3358e+5 real (kind=kind_phys), parameter :: lsubs = 2.83e+6 ! ? in sflx, snopac real (kind=kind_phys), parameter :: elcp = 2.4888e+3 ! ? in penman ! real (kind=kind_phys), parameter :: rd = con_rd ! con_rd =287.05 - real (kind=kind_phys), parameter :: rd1 = 287.04 ! con_rd in sflx, penman, canres + real (kind=kind_phys), parameter :: rd = 287.04 ! con_rd in sflx, penman, canres real (kind=kind_phys), parameter :: cp = con_cp ! con_cp =1004.6 real (kind=kind_phys), parameter :: cp = 1004.5 ! con_cp in sflx, canres real (kind=kind_phys), parameter :: cp2 = 1004.0 ! con_cp in htr @@ -870,32 +870,59 @@ subroutine gfssflx_hafs &! --- & hcpct_fasdas & & ) + eta_kinematic = eta + else !> - For a snowpack is present, call snopac(). call snopac -! --- inputs: ! -! ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, ! -! cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, ! -! bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, ! -! zsoil, dwsat, dksat, zbot, shdfac, ice, rtdis, quartz, ! -! fxexp, csoil, flx2, snowng, ! -! --- input/outputs: ! -! prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, ! -! sh2o, tbot, beta, ! -! --- outputs: ! -! smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, ! -! ett, snomlt, drip, dew, flx1, flx3, esnow ) ! +!................................... +! --- inputs: + & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, & + & cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, & + & bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, & + & zsoil, dwsat, dksat, zbot, shdfac, rtdis, quartz, & + & fxexp, csoil, flx2, snowng, & + & opt_thcnd, & +! --- input for fasdas (FDDA) (Not used for HAFS): + & qfx_phy, hcpct_fasdas, qfx_phy, fasdas, & +! --- input/inout for ua_phys: + & ua_phys, etpn, etpnd1, etp1n, flx4, & +! --- input/outputs: + & prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, & + & sh2o, tbot, beta, ribb, & + & sfhead1rt, infxs1rt, rtpnd1, & +! --- outputs: + & smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, & + & ett, snomlt, drip, dew, flx1, flx3, esnow, etns & + & hcpct_fasdas & + & ) + + eta_kinematic = esnow + etns - 1000.0*dew endif + !> - Noah LSM post-processing: !> - Calculate sensible heat (h) for return to parent model. - sheat = -(ch*cp1*sfcprs) / (rd1*t2v) * (th2 - t1) + sheat = -(ch*cp*sfcprs) / (rd*t2v) * (th2 - t1) + + if(ua_phys) sheat = sheat + flx4 +! +! fasdas +! + if ( fasdas == 1 ) then + hfx_phy = sheat + endif +! +! end fasdas +! + !> - Convert units and/or sign of total evap (eta), potential evap (etp), !! subsurface heat flux (s), and runoffs for what parent model expects. ! convert eta from kg m-2 s-1 to w m-2 +! lsubc was lvh2o in WRF: latent heat of water evap (J/kg) ! eta = eta * lsubc ! etp = etp * lsubc @@ -906,10 +933,14 @@ subroutine gfssflx_hafs &! --- et(k) = et(k) * lsubc enddo + etpnd1=etpnd1 * lsubc + ett = ett * lsubc esnow = esnow * lsubs etp = etp * ((1.0 - sncovr)*lsubc + sncovr*lsubs) + if(ua_phys) etpn = etpn*((1.-sncovr)*lsubc + sncovr*lsubs) + if (etp > 0.) then eta = edir + ec + ett + esnow else @@ -918,14 +949,22 @@ subroutine gfssflx_hafs &! --- beta = eta / etp + endif +! ---------------------------------------------------------------------- +! determine beta (ratio of actual to potential evap) +! ---------------------------------------------------------------------- + if (etp == 0.0) then + beta = 0.0 + else + beta = eta/etp + endif + !> - Convert the sign of soil heat flux so that: !! - ssoil>0: warm the surface (night time) !! - ssoil<0: cool the surface (day time) ssoil = -1.0 * ssoil - if (ice == 0) then - !> - For the case of land (but not glacial-ice): !! convert runoff3 (internal layer runoff from supersat) from \f$m\f$ !! to \f$ms^-1\f$ and add to subsurface runoff/baseflow (runoff2). @@ -934,16 +973,6 @@ subroutine gfssflx_hafs &! --- runoff3 = runoff3 / dt runoff2 = runoff2 + runoff3 - else - -!> - For the case of sea-ice (ice=1) or glacial-ice (ice=-1), add any -!! snowmelt directly to surface runoff (runoff1) since there is no -!! soil medium, and thus no call to subroutine smflx (for soil -!! moisture tendency). - - runoff1 = snomlt / dt - endif - !> - Calculate total column soil moisture in meters (soilm) and root-zone !! soil moisture availability (fraction) relative to porosity/saturation. @@ -954,12 +983,26 @@ subroutine gfssflx_hafs &! --- soilwm = -1.0 * (smcmax - smcwlt) * zsoil(1) soilww = -1.0 * (smc(1) - smcwlt) * zsoil(1) - do k = 2, nroot - soilwm = soilwm + (smcmax - smcwlt) * (zsoil(k-1) - zsoil(k)) - soilww = soilww + (smc(k) - smcwlt) * (zsoil(k-1) - zsoil(k)) - enddo - soilw = soilww / soilwm + + do k = 1,nsoil + smav(k)=(smc(k) - smcwlt)/(smcmax - smcwlt) + end do + + if (nroot >= 2) then + do k = 2,nroot + soilwm = soilwm + (smcmax - smcwlt)*(zsoil(k-1)-zsoil (k)) + soilww = soilww + (smc(k) - smcwlt)*(zsoil(k-1)-zsoil (k)) + end do + end if + if (soilwm .lt. 1.e-6) then + soilwm = 0.0 + soilw = 0.0 + soilm = 0.0 + else + soilw = soilww / soilwm + end if + ! return @@ -1280,7 +1323,7 @@ subroutine canres (swdn,ch,sfctmp,q2,sfcprs,smc,zsoil,nsoil, & ! evaporation (containing rc term). rc = rsmin / (xlai*rcs*rct*rcq*rcsoil) - rr = (4.0*sfcems*sigma*rd1/cpx1) * (sfctmp**4.0)/(sfcprs*ch) + 1.0 + rr = (4.0*sfcems*sigma*rd/cpx1) * (sfctmp**4.0)/(sfcprs*ch) + 1.0 delta = (lsubc/cpx1) * dqsdt2 pc = (rr + delta) / (rr*(1.0 + rc*ch) + delta) @@ -1597,6 +1640,8 @@ subroutine nopac & edir1, ec1, et1, & ! --- input/outputs: & cmc, sh2o, & +! --- wrf hydro input/outputs: + & fhead1rt,infxs1rt, & ! --- outputs: & smc, runoff1, runoff2, runoff3, drip & & ) @@ -1664,6 +1709,8 @@ subroutine nopac & edir1, ec1, et1, & ! --- input/outputs: & cmc, sh2o, & +! --- wrf hydro input/outputs: + & fhead1rt,infxs1rt, & ! --- outputs: & smc, runoff1, runoff2, runoff3, drip & & ) @@ -1836,7 +1883,7 @@ subroutine penman delta = elcp1 * dqsdt2 t24 = sfctmp * sfctmp * sfctmp * sfctmp rr = sfcems * t24 * 6.48e-8 / (sfcprs*ch) + 1.0 - rho = sfcprs / (rd1*t2v) + rho = sfcprs / (rd*t2v) rch = rho * cp * ch ! --- ... adjust the partial sums / products with the latent heat @@ -1845,7 +1892,7 @@ subroutine penman if (.not. snowng) then if (prcp > 0.0) rr = rr + cph2o*prcp/rch else - rr = rr + cpice & + rr = rr + cpice & & *prcp/rch endif @@ -3049,22 +3096,43 @@ subroutine snopac ex = 0.0 snomlt = 0.0 flx3 = 0.0 - + if(ua_phys) flx4 = 0.0 +! ---------------------------------------------------------------------- +! sublimation less than depth of snowpack +! snowpack (esd) reduced by esnow2 (depth of sublimated snow) +! ---------------------------------------------------------------------- else ! --- ... potential evap (sublimation) less than depth of snowpack, retain ! beta=1. sneqv = sneqv - esnow2 + etp3 = etp * lsubc + seh = rch * (t1 - th2) t14 = t1 * t1 t14 = t14 * t14 - flx3 = fdown - flx1 - flx2 - sfcems*sigma1*t14 & + flx3 = fdown - flx1 - flx2 - sfcems*sigma*t14 & & - ssoil - seh - etanrg if (flx3 <= 0.0) flx3 = 0.0 + + + if(ua_phys .and. flx4 > 0. .and. flx3 > 0.) then + if(flx3 >= flx4) then + flx3 = flx3 - flx4 + else + flx4 = flx3 + flx3 = 0. + endif + else + flx4 = 0.0 + endif + + + ex = flx3 * 0.001 / lsubf ! --- ... snowmelt reduction depending on snow cover @@ -3095,7 +3163,7 @@ subroutine snopac endif ! end if_sneqv-esnow2_block -! prcp1 = prcp1 + ex + prcp1 = prcp1 + ex ! --- ... if non-glacial land, add snowmelt rate (ex) to precip rate to be used ! in subroutine smflx (soil moisture evolution) via infiltration. @@ -3104,7 +3172,6 @@ subroutine snopac ! runoff/baseflow later near the end of sflx (after return from call to ! subroutine snopac) - if (ice == 0) prcp1 = prcp1 + ex endif ! end if_t12<=tfreez_block @@ -3117,17 +3184,18 @@ subroutine snopac ! if sea-ice (ice=1) or glacial-ice (ice=-1), skip call to smflx, since ! no soil medium for sea-ice or glacial-ice - if (ice == 0) then call smflx & ! --- inputs: - & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & - & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & - & edir1, ec1, et1, & + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & ! --- input/outputs: - & cmc, sh2o, & + & cmc, sh2o, & +! --- wrf hydro input/outputs: + & fhead1rt,infxs1rt, & ! --- outputs: - & smc, runoff1, runoff2, runoff3, drip & + & smc, runoff1, runoff2, runoff3, drip & & ) endif @@ -3162,78 +3230,27 @@ subroutine snopac ! --- ... snow depth and density adjustment based on snow compaction. yy is ! assumed to be the soil temperture at the top of the soil column. - if (ice == 0) then ! for non-glacial land - if (sneqv > 0.0) then + if (sneqv > 0.0) then call snowpack & ! --- inputs: - & ( sneqv, dt, t1, yy, & + & ( sneqv, dtsec, tsnow, tsoil, & +! --- ua_phys inputs: + & ( snomlt, ua_phys, & ! --- input/outputs: & snowh, sndens & & ) - else + else sneqv = 0.0 snowh = 0.0 sndens = 0.0 -! sncond = 1.0 + sncond = 1.0 sncovr = 0.0 - endif ! end if_sneqv_block - -! --- ... over sea-ice or glacial-ice, if s.w.e. (sneqv) below threshold lower -! bound (0.01 m for sea-ice, 0.10 m for glacial-ice), then set at -! lower bound and store the source increment in subsurface runoff/ -! baseflow (runoff2). note: runoff2 is then a negative value (as -! a flag) over sea-ice or glacial-ice, in order to achieve water balance. - - elseif (ice == 1) then ! for sea-ice - - if (sneqv >= 0.01) then - - call snowpack & -! --- inputs: - & ( sneqv, dt, t1, yy, & -! --- input/outputs: - & snowh, sndens & - & ) - - else - -! sndens = sneqv / snowh -! runoff2 = -(0.01 - sneqv) / dt - sneqv = 0.01 - snowh = 0.05 - sncovr = 1.0 -! snowh = sneqv / sndens - - endif ! end if_sneqv_block - - else ! for glacial-ice - - if (sneqv >= 0.10) then - - call snowpack & -! --- inputs: - & ( sneqv, dt, t1, yy, & -! --- input/outputs: - & snowh, sndens & - & ) - - else - -! sndens = sneqv / snowh -! runoff2 = -(0.10 - sneqv) / dt - sneqv = 0.10 - snowh = 0.50 - sncovr = 1.0 -! snowh = sneqv / sndens - - endif ! end if_sneqv_block - - endif ! end if_ice_block + endif ! end if_sneqv_block ! return @@ -3350,12 +3367,13 @@ subroutine snowz0 ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- inputs: - real(kind=kind_phys), intent(in) :: sncovr, z0brd, snowh, fbur - real(kind=kind_phys), intent(in) :: fgsn, shdmax, snowh + real(kind=kind_phys), intent(in) :: sncovr, z0brd, snowh, fbur + real(kind=kind_phys), intent(in) :: fgsn, shdmax, snowh ! --- outputs: - real(kind=kind_phys), intent(out) :: z0 + real(kind=kind_phys), intent(out) :: z0 ! --- logical: logical :: ua_phys @@ -3627,6 +3645,7 @@ subroutine evapo & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- inputs: integer, intent(in) :: nsoil, nroot @@ -3719,6 +3738,34 @@ subroutine evapo & end subroutine evapo !----------------------------------- + subroutine fac2mit +! --- input + & (smcmax, +! --- output + & flimit) + + implicit none + real, intent(in) :: smcmax + real, intent(out) :: flimit + + flimit = 0.90 + + if ( smcmax == 0.395 ) then + flimit = 0.59 + else if ( ( smcmax == 0.434 ) .or. ( smcmax == 0.404 ) ) then + flimit = 0.85 + else if ( ( smcmax == 0.465 ) .or. ( smcmax == 0.406 ) ) then + flimit = 0.86 + else if ( ( smcmax == 0.476 ) .or. ( smcmax == 0.439 ) ) then + flimit = 0.74 + else if ( ( smcmax == 0.200 ) .or. ( smcmax == 0.464 ) ) then + flimit = 0.80 + endif + +! ---------------------------------------------------------------------- + return +! ---------------------------------------------------------------------- + !----------------------------------- !>\ingroup Noah_LSM @@ -3892,15 +3939,17 @@ end subroutine shflx !! that is updated with prognostic equations. The canopy moisture content !! (cmc) is also updated. Frozen ground version: new states added: sh2o and !! frozen ground correction factor, frzx and parameter slope. - subroutine smflx & + subroutine smflx & ! --- inputs: - & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & - & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & - & edir1, ec1, et1, & + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & ! --- input/outputs: - & cmc, sh2o, & + & cmc, sh2o, & +! --- wrf hydro input/outputs: + & fhead1rt,infxs1rt, & ! --- outputs: - & smc, runoff1, runoff2, runoff3, drip & + & smc, runoff1, runoff2, runoff3, drip & & ) ! ===================================================================== ! @@ -3949,6 +3998,7 @@ subroutine smflx & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- inputs: integer, intent(in) :: nsoil @@ -3958,15 +4008,19 @@ subroutine smflx & ! --- input/outputs: real (kind=kind_phys), intent(inout) :: cmc, sh2o(nsoil) + real (kind=kind_phys), intent(inout) :: smc(nsoil) + +! --- wrf hydro input/output + real (kind=kind_phys), intent(inout) :: sfhead1rt,infxs1rt ! --- outputs: - real (kind=kind_phys), intent(out) :: smc(nsoil), runoff1, & + real (kind=kind_phys), intent(out) :: runoff1, & & runoff2, runoff3, drip ! --- locals: real (kind=kind_phys) :: dummy, excess, pcpdrp, rhsct, trhsct, & - & rhstt(nsold), sice(nsold), sh2oa(nsold), sh2ofg(nsold), & - & ai(nsold), bi(nsold), ci(nsold) + & rhstt(nsoil), sice(nsoil), sh2oa(nsoil), sh2ofg(nsoil), & + & ai(nsoil), bi(nsoil), ci(nsoil), stcf(nsoil), rhsts(nsoil) integer :: i, k ! @@ -4021,8 +4075,27 @@ subroutine smflx & ! of section 2 of kalnay and kanamitsu ! pcpdrp is units of kg/m**2/s or mm/s, zsoil is negative depth in m +! ---------------------------------------------------------------------- +! according to dr. ken mitchell's suggestion, add the second contraint +! to remove numerical instability of runoff and soil moisture +! flimit is a limit value for fac2 + fac2=0.0 + do i=1,nsoil + fac2=max(fac2,sh2o(i)/smcmax) + enddo + call fac2mit(smcmax,flimit) + +! ---------------------------------------------------------------------- +! frozen ground version: +! smc states replaced by sh2o states in srt subr. sh2o & sice states +! inc&uded in sstep subr. frozen ground correction factor, frzfact +! added. all water balance calculations using unfrozen water +! ---------------------------------------------------------------------- + + ! if ( pcpdrp .gt. 0.0 ) then - if ( (pcpdrp*dt) > (0.001*1000.0*(-zsoil(1))*smcmax) ) then + if ( ( (pcpdrp * dt) > (0.0001*1000.0* (- zsoil (1))* smcmax) ) & + .or. (fac2 > flimit) ) then ! --- ... frozen ground version: ! smc states replaced by sh2o states in srt subr. sh2o & sice states @@ -4088,7 +4161,6 @@ subroutine smflx & endif -! runof = runoff ! return !................................... @@ -4105,7 +4177,9 @@ end subroutine smflx !! and \a sndens . subroutine snowpack & ! --- inputs: - & ( esd, dtsec, tsnow, tsoil, & + & ( sneqv, dtsec, tsnow, tsoil, & +! --- ua_phys inputs: + & ( snomlt, ua_phys, & ! --- input/outputs: & snowh, sndens & & ) @@ -4138,12 +4212,16 @@ subroutine snowpack & ! ! ! ==================== end of description ===================== ! ! + implicit none ! --- parameter constants: real (kind=kind_phys), parameter :: c1 = 0.01 real (kind=kind_phys), parameter :: c2 = 21.0 + real (kind=kind_phys), parameter :: kn = 4000.0 ! --- inputs: - real (kind=kind_phys), intent(in) :: esd, dtsec, tsnow, tsoil + real (kind=kind_phys), intent(in) :: sneqv, dtsec, tsnow, tsoil + logical, intent(in) :: ua_phys ! ua: flag for ua option + real (kind=kind_phys), intent(in) :: snomlt ! ua: snow melt [m] ! --- input/outputs: real (kind=kind_phys), intent(inout) :: snowh, sndens @@ -4151,6 +4229,7 @@ subroutine snowpack & ! --- locals: real (kind=kind_phys) :: bfac, dsx, dthr, dw, snowhc, pexp, & & tavgc, tsnowc, tsoilc, esdc, esdcx + real (kind=kind_phys) :: snomltc ! ua: snow melt [cm] integer :: ipol, j ! @@ -4159,8 +4238,9 @@ subroutine snowpack & ! --- ... conversion into simulation units snowhc = snowh * 100.0 - esdc = esd * 100.0 + esdc = sneqv * 100.0 dthr = dtsec / 3600.0 + if(ua_phys) snomltc = snomlt * 100.0 tsnowc = tsnow - tfreez tsoilc = tsoil - tfreez @@ -4241,8 +4321,11 @@ subroutine snowpack & if (tsnowc >= 0.0) then dw = 0.13 * dthr / 24.0 + if ( ua_phys .and. tsoilc >= 0.) then + dw = min (dw, 0.13*snomltc/(esdcx+0.13*snomltc)) + endif sndens = sndens*(1.0 - dw) + dw - if (sndens > 0.40) sndens = 0.40 + if (sndens >= 0.40) sndens = 0.40 endif ! --- ... calculate snow depth (cm) from snow water equivalent and snow @@ -5277,7 +5360,9 @@ subroutine snksrc & ! ==================== end of description ===================== ! ! ! --- parameter constants: - real (kind=kind_phys), parameter :: dh2o = 1.0000e3 + real (kind=kind_phys), parameter :: dh2o = 1.0000e3 + real (kind=kind_phys), parameter :: hlice = 3.3350e5 + real (kind=kind_phys), parameter :: t0 = 2.7315e2 ! --- inputs: integer, intent(in) :: nsoil, k @@ -5292,7 +5377,8 @@ subroutine snksrc & real (kind=kind_phys), intent(out) :: tsrc ! --- locals: - real (kind=kind_phys) :: dz, free, xh2o + real (kind=kind_phys) :: df, dz, dzh, free, tsnsr, tdn, tm, xh2o + real (kind=kind_phys) :: tup, tz, x0, xdn, xup ! --- external functions: ! real (kind=kind_phys) :: frh2o @@ -5324,7 +5410,7 @@ subroutine snksrc & call frh2o & ! --- inputs: - & ( tavg, smc, sh2o, smcmax, bexp, psisat, & + & (tkelv, smc, sh2o, smcmax, bexp, psisat, & ! --- outputs: & free & & ) @@ -5427,9 +5513,9 @@ subroutine srt & ! rhstt - real, soil water time tendency nsoil ! ! runoff1 - real, surface runoff not infiltrating sfc 1 ! ! runoff2 - real, sub surface runoff (baseflow) 1 ! -! ai - real, matrix coefficients nsold ! -! bi - real, matrix coefficients nsold ! -! ci - real, matrix coefficients nsold ! +! ai - real, matrix coefficients nsoil ! +! bi - real, matrix coefficients nsoil ! +! ci - real, matrix coefficients nsoil ! ! ! ! ==================== end of description ===================== ! ! @@ -5443,18 +5529,23 @@ subroutine srt & real (kind=kind_phys), intent(in) :: edir, pcpdrp, dwsat, dksat, & & smcmax, smcwlt, bexp, dt, slope, kdt, frzx + ! --- outputs: real (kind=kind_phys), intent(out) :: runoff1, runoff2, & - & rhstt(nsoil), ai(nsold), bi(nsold), ci(nsold) + & rhstt(nsoil), ai(nsoil), bi(nsoil), ci(nsoil) ! --- locals: real (kind=kind_phys) :: acrt, dd, ddt, ddz, ddz2, denom, denom2, & & dice, dsmdz, dsmdz2, dt1, fcr, infmax, mxsmc, mxsmc2, px, & & numer, pddum, sicemax, slopx, smcav, sstt, sum, val, wcnd, & - & wcnd2, wdf, wdf2, dmax(nsold) + & wcnd2, wdf, wdf2, dmax(nsoil) + +! --- wrf_hydro locals: + real (kind=kind_phys) :: sfcwatr, chcksm + + integer :: ialp1, iohinf, j, jj, k, ks - integer :: cvfrz, ialp1, iohinf, j, jj, k, ks ! !===> ... begin here ! @@ -5529,11 +5620,11 @@ subroutine srt & ! --- ... frozen ground version: ! reduction of infiltration based on frozen ground parameters - fcr = 1. + fcr = 1.0 if (dice > 1.e-2) then acrt = cvfrz * frzx / dice - sum = 1. + sum = 1.0 ialp1 = cvfrz - 1 do j = 1, ialp1 From cd674fba87a6473bfdec8c7606bf6c99b7e969c5 Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Sun, 26 Jan 2020 23:49:00 +0000 Subject: [PATCH 08/16] Still updating --- physics/sflx_hafs.f | 352 ++++++++++++++------------------------------ 1 file changed, 112 insertions(+), 240 deletions(-) diff --git a/physics/sflx_hafs.f b/physics/sflx_hafs.f index 2d4ab1059..2328da039 100644 --- a/physics/sflx_hafs.f +++ b/physics/sflx_hafs.f @@ -122,7 +122,8 @@ subroutine gfssflx_hafs &! --- & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & & flx1, flx2, flx3, runoff1, runoff2, runoff3, & & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & - & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax, & + & flx4, fvb, fbur, fgsn, ztopv, zbotv, gama, fnet, etpn, ru &! --- ua_phys ! ===================================================================== ! ! description: ! @@ -282,6 +283,10 @@ subroutine gfssflx_hafs &! --- ! at the present time, those diverse values are kept temperately to ! provide the same result as the original codes. -- y.t.h. may09 +!MKB These came through WRF Registry, need to think how to get them in +!CCPP + integer, parameter :: opt_thcnd = 1 !< thermal conductivity + integer, parameter :: nsold = 4 !< max soil layers integer :: defined_soil @@ -326,6 +331,8 @@ subroutine gfssflx_hafs &! --- real (kind=kind_phys), intent(inout) :: tbot, cmc, t1, sneqv, & & stc(nsoil), smc(nsoil), sh2o(nsoil), ch, cm + real (kind=kind_phys), intent(inout) :: fhead1rt,infxs1rt, etpnd1 + ! --- outputs: integer, intent(out) :: nroot @@ -334,7 +341,8 @@ subroutine gfssflx_hafs &! --- & beta, etp, ssoil, flx1, flx2, flx3, snomlt, sncovr, & & runoff1, runoff2, runoff3, rc, pc, rsmin, xlai, rcs, & & rct, rcq, rcsoil, soilw, soilm, smcwlt, smcdry, smcref, & - & smcmax + & smcmax, & + & eta_kinematic ! --- locals: ! real (kind=kind_phys) :: df1h, @@ -359,6 +367,20 @@ subroutine gfssflx_hafs &! --- real (kind=kind_phys) :: cpx, cpx1, cpfac, xx1, xx2 real (kind=kind_phys), parameter :: z0min=0.2_kind_phys, & & z0max=1.0_kind_phys + + logical, intent(in) :: ua_phys ! ua: flag for ua option + real (kind=kind_phys),intent(out) :: flx4 ! ua: energy added to sensible heat + real (kind=kind_phys),intent(out) :: fvb ! ua: frac. veg. w/snow beneath + real (kind=kind_phys),intent(out) :: fbur ! ua: fraction of canopy buried + real (kind=kind_phys),intent(out) :: fgsn ! ua: ground snow cover fraction + real :: ztopv ! ua: height of canopy top + real :: zbotv ! ua: height of canopy bottom + real :: gama ! ua: = exp(-1.* xlai) + real :: fnet ! ua: + real :: etpn ! ua: + real :: ru ! ua: + + ua_phys = .false. ! !===> ... begin here ! @@ -860,7 +882,7 @@ subroutine gfssflx_hafs &! --- & zbot, rtdis, quartz, fxexp, csoil, & & opt_thcnd, & ! --- input for fasdas (FDDA) (Not used for HAFS): - & qfx_phy, hcpct_fasdas, xsda_qfx, qfx_phy, xqnorm, fasdas, & + & qfx_phy, hcpct_fasdas, xsda_qfx, xqnorm, fasdas, & ! --- input/outputs: & cmc, t1, stc, sh2o, tbot, & & sfhead1rt, infxs1rt, rtpnd1, & @@ -1413,7 +1435,7 @@ subroutine nopac & zbot, rtdis, quartz, fxexp, csoil, & & opt_thcnd, & ! --- input for fasdas (FDDA) (Not used for HAFS): - & qfx_phy, hcpct_fasdas, xsda_qfx, qfx_phy, xqnorm, fasdas, & + & qfx_phy, hcpct_fasdas, xsda_qfx, xqnorm, fasdas, & ! --- input/outputs: & cmc, t1, stc, sh2o, tbot, & & sfhead1rt, infxs1rt, rtpnd1, & @@ -4510,7 +4532,7 @@ subroutine frh2o & else - if (ck /= 0.0) then + if (ck /= 0.0) then ! --- ... option 1: iterated solution for nonzero ck ! in koren et al, jgr, 1999, eqn 17 @@ -4525,10 +4547,12 @@ subroutine frh2o & ! --- ... start of iterations + if (swl < 0.) swl = 0. + do while ( (nlog < 10) .and. (kcount == 0) ) nlog = nlog + 1 - df = alog( (psis*gs2/lsubf) * ( (1.0 + ck*swl)**2.0 ) & + df = alog( (psis*gs/lsubf) * ( (1.0 + ck*swl)**2.0 ) & & * (smcmax/(smc-swl))**bx ) - alog(-(tkelv-tfreez)/tkelv) denom = 2.0*ck/(1.0 + ck*swl) + bx/(smc - swl) @@ -4557,12 +4581,14 @@ subroutine frh2o & endif ! end if_ck_block + endif ! end if_ck_block + ! --- ... option 2: explicit solution for flerchinger eq. i.e. ck=0 ! in koren et al., jgr, 1999, eqn 17 ! apply physical bounds to flerchinger solution if (kcount == 0) then - fk = ( ( (lsubf/(gs2*(-psis))) & + fk = ( ( (lsubf/(gs*(-psis))) & & * ((tkelv-tfreez)/tkelv) )**(-1/bx) ) * smcmax fk = max( fk, 0.02 ) @@ -4588,11 +4614,13 @@ subroutine hrt & ! --- inputs: & ( nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, & & zbot, psisat, dt, bexp, df1, quartz, csoil, vegtyp, & - & shdfac, & + & shdfac, soiltyp, & ! --- input/outputs: & sh2o, & ! --- outputs: - & rhsts, ai, bi, ci & + & rhsts, ai, bi, ci, & +! --- outputs for fasdas: + & hcpct_fasdasi & & ) ! ===================================================================== ! @@ -4631,14 +4659,14 @@ subroutine hrt & ! ! ! outputs: ! ! rhsts - real, time tendency of soil thermal diffusion nsoil ! -! ai - real, matrix coefficients nsold ! -! bi - real, matrix coefficients nsold ! -! ci - real, matrix coefficients nsold ! +! ai - real, matrix coefficients nsoil ! +! bi - real, matrix coefficients nsoil ! +! ci - real, matrix coefficients nsoil ! ! ! ! ==================== end of description ===================== ! ! ! --- inputs: - integer, intent(in) :: nsoil, vegtyp + integer, intent(in) :: nsoil, vegtyp, soiltyp real (kind=kind_phys), intent(in) :: stc(nsoil), smc(nsoil), & & smcmax, zsoil(nsoil), yy, zz1, tbot, zbot, psisat, dt, & @@ -4648,8 +4676,12 @@ subroutine hrt & real (kind=kind_phys), intent(inout) :: sh2o(nsoil) ! --- outputs: - real (kind=kind_phys), intent(out) :: rhsts(nsoil), ai(nsold), & - & bi(nsold), ci(nsold) + real (kind=kind_phys), intent(out) :: rhsts(nsoil), ai(nsoil), & + & bi(nsoil), ci(nsoil) + +! fasdas +! + real (kind=kind_phys), intent(out) :: hcpct_fasdas ! --- locals: real (kind=kind_phys) :: ddz, ddz2, denom, df1n, df1k, dtsdz, & @@ -4663,15 +4695,12 @@ subroutine hrt & ! !===> ... begin here ! - csoil_loc=csoil - - if (ivegsrc == 1)then !urban if( vegtyp == 13 ) then -! csoil_loc=3.0e6 - csoil_loc=3.0e6*(1.-shdfac)+csoil*shdfac ! gvf + csoil_loc=3.0e6 + else + csoil_loc=csoil endif - endif ! --- ... initialize logical for soil layer temperature averaging. @@ -4699,13 +4728,23 @@ subroutine hrt & dtsdz = (stc(1) - stc(2)) / (-0.5*zsoil(2)) ssoil = df1 * (stc(1) - yy) / (0.5*zsoil(1)*zz1) - rhsts(1) = (df1*dtsdz - ssoil) / (zsoil(1)*hcpct) + + denom = (zsoil (1) * hcpct) + +! ---------------------------------------------------------------------- +! next capture the vertical difference of the heat flux at top and +! bottom of first soil layer for use in heat flux constraint applied to +! potential soil freezing/thawing in routine snksrc. +! ---------------------------------------------------------------------- +! rhsts(1) = (df1*dtsdz - ssoil) / (zsoil(1)*hcpct) + rhsts (1) = (df1 * dtsdz - ssoil) / denom + ! --- ... next capture the vertical difference of the heat flux at top and ! bottom of first soil layer for use in heat flux constraint applied to ! potential soil freezing/thawing in routine snksrc. - qtot = ssoil - df1*dtsdz + qtot = -1.0* rhsts (1)* denom ! --- ... if temperature averaging invoked (itavg=true; else skip): ! set temp "tsurf" at top of soil column (for use in freezing soil @@ -4738,10 +4777,9 @@ subroutine hrt & ! compute heat source/sink (and change in frozen water content) ! due to possible soil water phase change - if ( (sice > 0.0) .or. (tsurf < tfreez) .or. & + if ( (sice > 0.0) .or. (tsurf < tfreez) .or. & & (stc(1) < tfreez) .or. (tbk < tfreez) ) then - if (itavg) then call tmpavg & ! --- inputs: @@ -4750,27 +4788,40 @@ subroutine hrt & & tavg & & ) - else + call snksrc & +! --- inputs: + & ( nsoil, 1, tavg, smc(1), smcmax, psisat, bexp, dt, & + & qtot, zsoil, & +! --- input/outputs: + & sh2o(1), & +! --- outputs: + & tsnsr & + & ) - tavg = stc(1) - endif ! end if_itavg_block + rhsts(1) = rhsts(1) - tsnsr / denom + endif ! end if_sice_block + else + if ( (sice > 0.) .or. (stc (1) < t0) ) then call snksrc & ! --- inputs: & ( nsoil, 1, tavg, smc(1), smcmax, psisat, bexp, dt, & - & qtot, zsoil, shdfac, & + & qtot, zsoil, & ! --- input/outputs: & sh2o(1), & ! --- outputs: & tsnsr & & ) +! rhsts(1) = rhsts(1) - tsnsr / ( zsoil(1) * hcpct ) + rhsts (1) = rhsts (1) - tsnsr / denom + endif +! ---------------------------------------------------------------------- +! this ends section for top soil layer. +! ---------------------------------------------------------------------- + endif - rhsts(1) = rhsts(1) - tsnsr / ( zsoil(1)*hcpct ) - - endif ! end if_sice_block - ! === this ends section for top soil layer. ! --- ... initialize ddz2 @@ -4802,12 +4853,8 @@ subroutine hrt & & ) !urban ! if (ivegsrc == 1)then -! if ( vegtyp == 13 ) df1n = 3.24 + if ( vegtyp == 13 ) df1n = 3.24 ! endif -!wz only urban for igbp type - if(ivegsrc == 1 .and. vegtyp == 13) then - df1n = 3.24*(1.-shdfac) + shdfac*df1n - endif ! --- ... calc the vertical soil temp gradient thru this layer @@ -4833,7 +4880,7 @@ subroutine hrt & endif - else + endif ! --- ... special case of bottom soil layer: calculate thermal diffusivity ! for bottom layer. @@ -4886,33 +4933,43 @@ subroutine hrt & qtot = -1.0 * denom * rhsts(k) sice = smc(k) - sh2o(k) - if ( (sice > 0.0) .or. (tbk < tfreez) .or. & - & (stc(k) < tfreez) .or. (tbk1 < tfreez) ) then - - if (itavg) then - + if (itavg) then call tmpavg & ! --- inputs: & ( tbk, stc(k), tbk1, zsoil, nsoil, k, & ! --- outputs: & tavg & & ) + if ( (sice > 0.0) .or. (tbk < tfreez) .or. & + & (stc(k) < tfreez) .or. (tbk1 < tfreez) ) then - else - tavg = stc(k) - endif + call snksrc & +! --- inputs: + & ( nsoil, k, tavg, smc(k), smcmax, psisat, bexp, dt, & + & qtot, zsoil, & +! --- input/outputs: + & sh2o(k), & +! --- outputs: + & tsnsr & + & ) + rhsts(k) = rhsts(k) - tsnsr/denom + + endif + else + if ( (sice > 0.0) .or. (stc(k) < tfreez) ) then call snksrc & ! --- inputs: & ( nsoil, k, tavg, smc(k), smcmax, psisat, bexp, dt, & - & qtot, zsoil, shdfac, & + & qtot, zsoil, & ! --- input/outputs: & sh2o(k), & ! --- outputs: & tsnsr & & ) + rhsts(k) = rhsts(k) - tsnsr/denom + endif - rhsts(k) = rhsts(k) - tsnsr/denom endif ! --- ... calc matrix coefs, ai, and bi for this layer. @@ -4935,182 +4992,6 @@ subroutine hrt & end subroutine hrt !----------------------------------- - -!----------------------------------- -!>\ingroup Noah_LSM -!> This subroutine calculates the right hand side of the time tendency -!! term of the soil thermal diffusion equation for sea-ice (ice = 1) or -!! glacial-ice (ice). - subroutine hrtice & -! --- inputs: - & ( nsoil, stc, zsoil, yy, zz1, df1, ice, & -! --- input/outputs: - & tbot, & -! --- outputs: - & rhsts, ai, bi, ci & - & ) - -! ===================================================================== ! -! description: ! -! ! -! subroutine hrtice calculates the right hand side of the time tendency! -! term of the soil thermal diffusion equation for sea-ice (ice = 1) or ! -! glacial-ice (ice). compute (prepare) the matrix coefficients for the ! -! tri-diagonal matrix of the implicit time scheme. ! -! (note: this subroutine only called for sea-ice or glacial ice, but ! -! not for non-glacial land (ice = 0). ! -! ! -! subprogram called: none ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! nsoil - integer, number of soil layers 1 ! -! stc - real, soil temperature nsoil ! -! zsoil - real, soil depth (negative sign, as below grd) nsoil ! -! yy - real, soil temperature at the top of column 1 ! -! zz1 - real, 1 ! -! df1 - real, thermal diffusivity and conductivity 1 ! -! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! -! ! -! input/outputs: ! -! tbot - real, bottom soil temperature 1 ! -! ! -! outputs: ! -! rhsts - real, time tendency of soil thermal diffusion nsoil ! -! ai - real, matrix coefficients nsold ! -! bi - real, matrix coefficients nsold ! -! ci - real, matrix coefficients nsold ! -! ! -! ==================== end of description ===================== ! -! -! --- inputs: - integer, intent(in) :: nsoil, ice - - real (kind=kind_phys), intent(in) :: stc(nsoil), zsoil(nsoil), & - & yy, zz1, df1 - -! --- input/outputs: - real (kind=kind_phys), intent(inout) :: tbot - -! --- outputs: - real (kind=kind_phys), intent(out) :: rhsts(nsoil), ai(nsold), & - & bi(nsold), ci(nsold) - -! --- locals: - real (kind=kind_phys) :: ddz, ddz2, denom, dtsdz, dtsdz2, & - & hcpct, ssoil, zbot - - integer :: k - -! -!===> ... begin here -! -! --- ... set a nominal universal value of the sea-ice specific heat capacity, -! hcpct = 1880.0*917.0 = 1.72396e+6 (source: fei chen, 1995) -! set bottom of sea-ice pack temperature: tbot = 271.16 -! set a nominal universal value of glacial-ice specific heat capacity, -! hcpct = 2100.0*900.0 = 1.89000e+6 (source: bob grumbine, 2005) -! tbot passed in as argument, value from global data set - - if (ice == 1) then -! --- ... sea-ice - hcpct = 1.72396e+6 - tbot = 271.16 - else -! --- ... glacial-ice - hcpct = 1.89000e+6 - endif - -! --- ... the input argument df1 is a universally constant value of sea-ice -! and glacial-ice thermal diffusivity, set in sflx as df1 = 2.2. - -! --- ... set ice pack depth. use tbot as ice pack lower boundary temperature -! (that of unfrozen sea water at bottom of sea ice pack). assume ice -! pack is of n=nsoil layers spanning a uniform constant ice pack -! thickness as defined by zsoil(nsoil) in routine sflx. -! if glacial-ice, set zbot = -25 meters - - if (ice == 1) then -! --- ... sea-ice - zbot = zsoil(nsoil) - else -! --- ... glacial-ice - zbot = -25.0 - endif - -! --- ... calc the matrix coefficients ai, bi, and ci for the top layer - - ddz = 1.0 / (-0.5*zsoil(2)) - ai(1) = 0.0 - ci(1) = (df1*ddz) / (zsoil(1)*hcpct) - bi(1) = -ci(1) + df1 / (0.5*zsoil(1)*zsoil(1)*hcpct*zz1) - -! --- ... calc the vertical soil temp gradient btwn the top and 2nd soil -! layers. recalc/adjust the soil heat flux. use the gradient and -! flux to calc rhsts for the top soil layer. - - dtsdz = (stc(1) - stc(2)) / (-0.5*zsoil(2)) - ssoil = df1 * (stc(1) - yy) / (0.5*zsoil(1)*zz1) - rhsts(1) = (df1*dtsdz - ssoil) / (zsoil(1)*hcpct) - -! --- ... initialize ddz2 - - ddz2 = 0.0 - -! --- ... loop thru the remaining soil layers, repeating the above process - - do k = 2, nsoil - - if (k /= nsoil) then - -! --- ... calc the vertical soil temp gradient thru this layer. - - denom = 0.5 * (zsoil(k-1) - zsoil(k+1)) - dtsdz2 = (stc(k) - stc(k+1)) / denom - -! --- ... calc the matrix coef, ci, after calc'ng its partial product. - - ddz2 = 2.0 / (zsoil(k-1) - zsoil(k+1)) - ci(k) = -df1*ddz2 / ((zsoil(k-1) - zsoil(k))*hcpct) - - else - -! --- ... calc the vertical soil temp gradient thru the lowest layer. - - dtsdz2 = (stc(k) - tbot) & - & / (0.5*(zsoil(k-1) + zsoil(k)) - zbot) - -! --- ... set matrix coef, ci to zero. - - ci(k) = 0.0 - - endif ! end if_k_block - -! --- ... calc rhsts for this layer after calc'ng a partial product. - - denom = (zsoil(k) - zsoil(k-1)) * hcpct - rhsts(k) = (df1*dtsdz2 - df1*dtsdz) / denom - -! --- ... calc matrix coefs, ai, and bi for this layer. - - ai(k) = - df1*ddz / ((zsoil(k-1) - zsoil(k)) * hcpct) - bi(k) = -(ai(k) + ci(k)) - -! --- ... reset values of dtsdz and ddz for loop to next soil lyr. - - dtsdz = dtsdz2 - ddz = ddz2 - - enddo ! end do_k_loop -! - return -!................................... - end subroutine hrtice -!----------------------------------- - - !----------------------------------- !>\ingroup Noah_LSM !> This subroutine calculates/updates the soil temperature field. @@ -5140,9 +5021,9 @@ subroutine hstep & ! ! ! input/outputs: ! ! rhsts - real, time tendency of soil thermal diffusion nsoil ! -! ai - real, matrix coefficients nsold ! -! bi - real, matrix coefficients nsold ! -! ci - real, matrix coefficients nsold ! +! ai - real, matrix coefficients nsoil ! +! bi - real, matrix coefficients nsoil ! +! ci - real, matrix coefficients nsoil ! ! ! ! outputs: ! ! stcout - real, updated soil temperature nsoil ! @@ -5156,7 +5037,7 @@ subroutine hstep & ! --- input/outputs: real (kind=kind_phys), intent(inout) :: rhsts(nsoil), & - & ai(nsold), bi(nsold), ci(nsold) + & ai(nsoil), bi(nsoil), ci(nsoil) ! --- outputs: real (kind=kind_phys), intent(out) :: stcout(nsoil) @@ -5184,7 +5065,7 @@ subroutine hstep & rhstsin(k) = rhsts(k) enddo - do k = 1, nsold + do k = 1, nsoil ciin(k) = ci(k) enddo @@ -5321,7 +5202,7 @@ end subroutine rosr12 subroutine snksrc & ! --- inputs: & ( nsoil, k, tavg, smc, smcmax, psisat, bexp, dt, & - & qtot, zsoil, shdfac, & + & qtot, zsoil, & ! --- input/outputs: & sh2o, & ! --- outputs: @@ -5361,7 +5242,6 @@ subroutine snksrc & ! ! --- parameter constants: real (kind=kind_phys), parameter :: dh2o = 1.0000e3 - real (kind=kind_phys), parameter :: hlice = 3.3350e5 real (kind=kind_phys), parameter :: t0 = 2.7315e2 ! --- inputs: @@ -5383,14 +5263,6 @@ subroutine snksrc & ! --- external functions: ! real (kind=kind_phys) :: frh2o -!urban -! if (ivegsrc == 1)then -! if ( vegtyp == 13 ) df1=3.24 -! endif -!wz only urban for igbp type - if(ivegsrc == 1 .and. vegtyp == 13) then - df1 = 3.24*(1.-shdfac) + shdfac*df1 - endif ! !===> ... begin here ! From 50d0a94dfeadb606096a7ad5d90055c83e13bced Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Mon, 27 Jan 2020 02:08:47 +0000 Subject: [PATCH 09/16] Adding meta data file for sflx_hafs.f --- physics/sflx_hafs.meta | 905 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 905 insertions(+) create mode 100644 physics/sflx_hafs.meta diff --git a/physics/sflx_hafs.meta b/physics/sflx_hafs.meta new file mode 100644 index 000000000..e529b3bce --- /dev/null +++ b/physics/sflx_hafs.meta @@ -0,0 +1,905 @@ +[ccpp-arg-table] + name = lsm_noah_init + type = scheme +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[isot] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for file opens + units = none + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = lsm_noah_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = lsm_noah_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rvrdm1] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ps] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = 1st model layer air temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = 1st model layer specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfcemis] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dlwflx] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dswsfc] + standard_name = surface_downwelling_shortwave_flux + long_name = total sky surface downward shortwave flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snet] + standard_name = surface_net_downwelling_shortwave_flux + long_name = total sky surface net shortwave flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[delt] + standard_name = time_step_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tg3] + standard_name = deep_soil_temperature + long_name = bottom soil temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = Model layer 1 mean pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = height above ground at 1st model layer + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[land] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[slopetyp] + standard_name = surface_slope_classification + long_name = surface slope type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[shdmin] + standard_name = minimum_vegetation_area_fraction + long_name = min fractional coverage of green veg + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractnl cover of green veg (not used) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snoalb] + standard_name = upper_bound_on_max_albedo_over_deep_snow + long_name = upper bound on max albedo over deep snow + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfalb] + standard_name = surface_diffused_shortwave_albedo + long_name = mean surface diffused shortwave albedo + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[lheatstrg] + standard_name = flag_for_canopy_heat_storage + long_name = flag for canopy heat storage parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[isot] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[bexppert] + standard_name = perturbation_of_soil_type_b_parameter + long_name = perturbation of soil type "b" parameter + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[xlaipert] + standard_name = perturbation_of_leaf_area_index + long_name = perturbation of leaf area index + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vegfpert] + standard_name = perturbation_of_vegetation_fraction + long_name = perturbation of vegetation fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[pertvegf] + standard_name = magnitude_of_perturbation_of_vegetation_fraction + long_name = magnitude of perturbation of vegetation fraction + units = frac + dimensions = (5) + type = real + kind = kind_phys + intent = in + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tskin] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[srflag] + standard_name = flag_for_precipitation_type + long_name = flag for snow or rain precipitation + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = volume fraction of unfrozen soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canopy] + standard_name = canopy_water_amount + long_name = canopy moisture content + units = kg m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[trans] + standard_name = transpiration_flux + long_name = total plant transpiration rate + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sncovr1] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qsurf] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[gflux] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land + long_name = momentum exchange coefficient over land + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land + long_name = thermal exchange coefficient over land + units = kg m-2 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[evbs] + standard_name = soil_upward_latent_heat_flux + long_name = soil upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[evcw] + standard_name = canopy_upward_latent_heat_flux + long_name = canopy upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sbsno] + standard_name = snow_deposition_sublimation_upward_latent_heat_flux + long_name = latent heat flux from snow depo/subl + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snowc] + standard_name = surface_snow_area_fraction + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stm] + standard_name = soil_moisture_content + long_name = soil moisture content + units = kg m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = soil water fraction at wilting point + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smcref2] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wet1] + standard_name = normalized_soil_wetness + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F +************************ +MKB Addition +************************ +[ffrozp] + standard_name = flag_snow_rain_detection + long_name = flag for snow-rain detection(1./0.=snow/rain) + units = flag + dimensions = (horizontal_dimension) + type = real + intent = in + optional = F +[dt] + standard_name = time_step_for_physics + long_name = time step for physics + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[zlvl] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sldpth] + standard_name = thickness_of_each_soil_layer + long_name = thickness of each soil layer (nsoil) + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[swdn] + standard_name = downward_shortwave_radiation_flux + long_name = downward shortwave radiation flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[swnet] + standard_name = downward_shortwave_net_flux + long_name = downward shortwave net (dn-up) flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[lwdn] + standard_name = downward_longwave_radiation_flux + long_name = downward longwave radiation flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfcems] + standard_name = surface_longwave_emissivity_over_land + long_name = surface lw emissivity in fraction over land + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfcprs] + standard_name = surface_air_pressure_at_height_zlvl_above_ground + long_name = surface pressure at height zlvl above ground + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfctmp] + standard_name = surface_temperature_height_zlvl_above_ground + long_name = surface temperature at height zlvl above ground + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfcspd] + standard_name = wind_speed_at_zlvl_above_ground + long_name = wind speed at zlvl above ground + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prcp] + standard_name = precipitation_rate_from_previous_timestep + long_name = precipitation rate from previous timestep + units = kg m-2 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q2] + standard_name = mixing_ratio_at_zlvl_above_ground + long_name = mixing_ratio_at_zlvl_above_ground + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q2sat] + standard_name = sat_mixing_ratio_at_zlvl_above_ground + long_name = sat mixing ratio at zlvl above ground + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dqsdt2] + standard_name = slope_sat_specific_humidity + long_name = slope of sat specific humidity curve at t=sfctmp + units = kg kg-1 k-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[vegtyp] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[alb] + standard_name = background_snow_free_surface_albedo + long_name = background snow free surface albedo + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snoalb] + standard_name = max_albedo_deep_snow + long_name = max albedo over deep snow + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F From 779ea620e63fc19496f60a53d032bb7a4a113d89 Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Mon, 27 Jan 2020 05:28:54 +0000 Subject: [PATCH 10/16] Updating sflx_hafs.meta --- physics/sflx_hafs.meta | 89 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) diff --git a/physics/sflx_hafs.meta b/physics/sflx_hafs.meta index e529b3bce..737a902bf 100644 --- a/physics/sflx_hafs.meta +++ b/physics/sflx_hafs.meta @@ -903,3 +903,92 @@ MKB Addition kind = kind_phys intent = in optional = F +[tbot] + standard_name = bottom_soil_temperature + long_name = bottom_soil_temperature (local yearly-mean sfc air tmp) + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cmc] + standard_name = canopy_water_amount + long_name = canopy moisture content + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[t1] + standard_name = ground_canopy_snowpack_effect_skin_temperature + long_name = ground canopy snowpack effect skin temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sh2o] + standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model + long_name = volume fraction of unfrozen soil moisture for lsm + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F +[sneqv] + standard_name = surface_snow_thickness_water_equivalent + long_name = water equivalent snow depth + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[z0] + standard_name = time_varying_roughness_length + long_name = time varying roughness length + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[z0brd] + standard_name = background_fixed_roughness_length + long_name = background fixed roughness length + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[nroot] + standard_name = number_of_root_layers + long_name = number of root layers function of vegtype + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[shdfac] + standard_name = areal_coverage_vegetation_area_fraction + long_name = areal coverage of green veg + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snowh] + standard_name = actual_snow_depth + long_name = snow depth + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F From aec95f0f0550a27928293cd0996496d9d6ea8269 Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Tue, 28 Jan 2020 01:49:00 +0000 Subject: [PATCH 11/16] Updating.. --- physics/sflx_hafs.f | 52 +++++++++++++++++++++++++++++++-------------- 1 file changed, 36 insertions(+), 16 deletions(-) diff --git a/physics/sflx_hafs.f b/physics/sflx_hafs.f index 2328da039..68fdcaf85 100644 --- a/physics/sflx_hafs.f +++ b/physics/sflx_hafs.f @@ -40,6 +40,7 @@ !!\param[in] swnet real, downward SW net (dn-up) flux (\f$W/m^2\f$) !!\param[in] lwdn real, downward LW radiation flux (\f$W/m^2\f$) !!\param[in] sfcems real, sfc LW emissivity (fractional) +!!\param[in] embrd real, background sfc LW emissivity (fractional) !!\param[in] sfcprs real, pressure at height zlvl above ground(\f$Pa\f$) !!\param[in] sfctmp real, air temp at height zlvl above ground (\f$K\f$) !!\param[in] sfcspd real, wind speed at height zlvl above ground (\f$m s^{-1}\f$) @@ -56,9 +57,11 @@ !!\param[in] shdmax real, max areal coverage of green veg (fraction) !!\param[in] alb real, background snow-free sfc albedo (fraction) !!\param[in] snoalb real, max albedo over deep snow (fraction) -!!\param[in] xlaip real, perturbation of leave area index (perturbation) -!!\param[in] lheatstrg logical, flag for canopy heat storage parameterization +!!\param[in] usemonalb logical, use 2d field (.true.) vs table (.false.)values +!!\param[in,out] snotime1 real, initial number of timesteps since last +!!snowfall !!\param[in,out] tbot real, bottom soil temp (\f$K\f$) (local yearly-mean sfc air temp) +!!\param[in,out] z0brd real, background fixed roughness length (m) !!\param[in,out] cmc real, canopy moisture content (\f$m\f$) !!\param[in,out] t1 real, ground/canopy/snowpack eff skin temp (\f$K\f$) !!\param[in,out] stc real, soil temp (\f$K\f$) @@ -70,11 +73,13 @@ !!\param[in,out] cm real, sfc exchange coeff for momentum !! (\f$ms^{-1}\f$), note: conductance since it's been mult by wind !!\param[in,out] z0 real, roughness length (\f$m\f$) +!!\param[in,out] ribb real, documentation needed !!\param[out] nroot integer, number of root layers !!\param[out] shdfac real, aeral coverage of green veg (fraction) !!\param[out] snowh real, snow depth (\f$m\f$) !!\param[out] albedo real, sfc albedo incl snow effect (fraction) !!\param[out] eta real, downward latent heat flux (\f$W/m^2\f$) +!!\param[out] eta_kinematic real, actual latent heat flux (\f$Kg/m^{-2}s^{-1}\f$) !!\param[out] sheat real, downward sensible heat flux (\f$W/m^2\f$) !!\param[out] ec real, canopy water evaporation (\f$W/m^2\f$) !!\param[out] edir real, direct soil evaporation (\f$W/m^2\f$) @@ -90,6 +95,10 @@ !!\param[out] flx1 real, precip-snow sfc flux (\f$W/m^2\f$) !!\param[out] flx2 real, freezing rain latent heat flux (\f$W/m^2\f$) !!\param[out] flx3 real, phase-change heat flux from snowmelt (\f$W/m^2\f$) +!!\param[out] flx4 real, energy added to sensible heat(ua_phys) (\f$W/m^2\f$) +!!\param[out] fvb real, frac veg w/snow beneath (ua_phys) (fraction) +!!\param[out] fbur real, frac of canopy buried (ua_phys) (fraction) +!!\param[out] fgsn real, frac of ground snow cover (ua_phys) (fraction) !!\param[out] runoff1 real, surface runoff (\f$ms^{-1}\f$) not infiltrating sfc !!\param[out] runoff2 real, sub sfc runoff (\f$ms^{-1}\f$) (baseflow) !!\param[out] runoff3 real, excess of porosity for a given soil layer @@ -105,6 +114,9 @@ !!\param[out] rcsoil real, soil moisture rc factor (dimensionless) !!\param[out] soilw real, available soil moisture in root zone !!\param[out] soilm real, total soil column moisture (frozen+unfrozen) (\f$m\f$) +!!\param[out] q1 real, mixing ratio at surface;used for diag (\f$kgkg^{-1}\f$) +!!\param[out] smav real, soil mois avail for each lyr, frac bet +!! smcwlt and smcmax !!\param[out] smcwlt real, wilting point (volumetric) !!\param[out] smcdry real, dry soil moisture threshold (volumetric) !!\param[out] smcref real, soil moisture threshold (volumetric) @@ -116,14 +128,15 @@ subroutine gfssflx_hafs &! --- & swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, & & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & & vegtyp, soiltyp, slopetyp, shdmin, shdmax, alb, snoalb, & - & lheatstrg, usemonalb, rdlai2d, &! --- input/outputs: + & z0brd, usemonalb, snotime1, ribb, &! --- input/outputs: & tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm,z0, &! --- outputs: & nroot, shdfac, snowh, albedo, eta, sheat, ec, & & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & & flx1, flx2, flx3, runoff1, runoff2, runoff3, & & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & - & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax, & - & flx4, fvb, fbur, fgsn, ztopv, zbotv, gama, fnet, etpn, ru &! --- ua_phys + & rcsoil, soilw, soilm, q1, smav, smcwlt, smcdry, smcref, & + & smcmax, embrd, eta_kinematic, & + & flx4, fvb, fbur, fgsn ! --- ua_phys ! ===================================================================== ! ! description: ! @@ -144,6 +157,7 @@ subroutine gfssflx_hafs &! --- ! swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, ! ! sfcspd, prcp, q2, q2sat, dqsdt2, th2,ivegsrc, ! ! vegtyp, soiltyp, slopetyp, shdmin, shdmax, alb, snoalb, ! +! z0brd, usemonalb, ! ! --- input/outputs: ! ! tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm, ! ! --- outputs: ! @@ -151,7 +165,7 @@ subroutine gfssflx_hafs &! --- ! edir, et, ett, esnow, drip, dew, beta, etp, ssoil, ! ! flx1, flx2, flx3, runoff1, runoff2, runoff3, ! ! snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, ! -! rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax ) ! +! rcsoil, soilw, soilm, q1, smcwlt, smcdry, smcref, smcmax ) ! ! ! ! ! ! subprograms called: redprm, snow_new, csnow, snfrac, alcalc, ! @@ -190,6 +204,7 @@ subroutine gfssflx_hafs &! --- ! swnet - real, downward sw net (dn-up) flux (w/m**2) 1 ! ! lwdn - real, downward lw radiation flux (w/m**2) 1 ! ! sfcems - real, sfc lw emissivity (fractional) 1 ! +! embrd - real, background sfc lw emissivity (fractional) 1 ! ! sfcprs - real, pressure at height zlvl abv ground(pascals) 1 ! ! sfctmp - real, air temp at height zlvl abv ground (k) 1 ! ! sfcspd - real, wind speed at height zlvl abv ground (m/s) 1 ! @@ -207,12 +222,11 @@ subroutine gfssflx_hafs &! --- ! shdmax - real, max areal coverage of green veg (fraction) 1 ! ! alb - real, bkground snow-free sfc albedo (fraction) 1 ! ! snoalb - real, max albedo over deep snow (fraction) 1 ! -! lheatstrg- logical, flag for canopy heat storage 1 ! -! parameterization ! ! ! ! input/outputs: ! ! tbot - real, bottom soil temp (k) 1 ! ! (local yearly-mean sfc air temp) ! +! z0brd - real, background fixed roughness length (m) 1 ! ! cmc - real, canopy moisture content (m) 1 ! ! t1 - real, ground/canopy/snowpack eff skin temp (k) 1 ! ! stc - real, soil temp (k) nsoil ! @@ -232,6 +246,7 @@ subroutine gfssflx_hafs &! --- ! snowh - real, snow depth (m) 1 ! ! albedo - real, sfc albedo incl snow effect (fraction) 1 ! ! eta - real, downward latent heat flux (w/m2) 1 ! +! eta_kinematic - real, actual latent heat flux (w/m2) 1 ! ! sheat - real, downward sensible heat flux (w/m2) 1 ! ! ec - real, canopy water evaporation (w/m2) 1 ! ! edir - real, direct soil evaporation (w/m2) 1 ! @@ -247,6 +262,7 @@ subroutine gfssflx_hafs &! --- ! flx1 - real, precip-snow sfc flux (w/m2) 1 ! ! flx2 - real, freezing rain latent heat flux (w/m2) 1 ! ! flx3 - real, phase-change heat flux from snowmelt (w/m2) 1 ! +! flx4 - real, energy added to sensible heat(ua_phys)w/m2) 1 ! ! snomlt - real, snow melt (m) (water equivalent) 1 ! ! sncovr - real, fractional snow cover 1 ! ! runoff1 - real, surface runoff (m/s) not infiltrating sfc 1 ! @@ -262,6 +278,8 @@ subroutine gfssflx_hafs &! --- ! rcsoil - real, soil moisture rc factor (dimensionless) 1 ! ! soilw - real, available soil mois in root zone 1 ! ! soilm - real, total soil column mois (frozen+unfrozen) (m)1 ! +! q1 - real, mixing ratio at surface (kg kg-1) 1 ! +! smav - real, soil mois avail for each layer 1 ! ! smcwlt - real, wilting point (volumetric) 1 ! ! smcdry - real, dry soil mois threshold (volumetric) 1 ! ! smcref - real, soil mois threshold (volumetric) 1 ! @@ -323,13 +341,13 @@ subroutine gfssflx_hafs &! --- & sfcspd, prcp, q2, q2sat, dqsdt2, th2, shdmin, shdmax, alb, & & snoalb, & - logical, intent(in) :: lheatstrg - logical, intent(in) :: usemonalb + logical, intent(in) :: usemonalb !true for HWRF logical, intent(in) :: rdlai2d ! --- input/outputs: real (kind=kind_phys), intent(inout) :: tbot, cmc, t1, sneqv, & - & stc(nsoil), smc(nsoil), sh2o(nsoil), ch, cm + & stc(nsoil), smc(nsoil), sh2o(nsoil), ch, cm, z0brd, & + & snotime1, ribb real (kind=kind_phys), intent(inout) :: fhead1rt,infxs1rt, etpnd1 @@ -340,8 +358,8 @@ subroutine gfssflx_hafs &! --- & eta, sheat, ec, edir, et(nsoil), ett, esnow, drip, dew, & & beta, etp, ssoil, flx1, flx2, flx3, snomlt, sncovr, & & runoff1, runoff2, runoff3, rc, pc, rsmin, xlai, rcs, & - & rct, rcq, rcsoil, soilw, soilm, smcwlt, smcdry, smcref, & - & smcmax, & + & rct, rcq, rcsoil, soilw, soilm, q1, smav, smcwlt, smcdry, & + & smcref, smcmax, embrd & & eta_kinematic ! --- locals: @@ -381,6 +399,7 @@ subroutine gfssflx_hafs &! --- real :: ru ! ua: ua_phys = .false. + rdlai2d = .false. ! !===> ... begin here ! @@ -834,7 +853,7 @@ subroutine gfssflx_hafs &! --- ! --- inputs: & ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, & & cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, & - & sncovr, sneqv, albedo, soldn, stc1, & + & sncovr, aoasis, sneqv, albedo, soldn, stc1, & ! --- outputs: & t24, etp, rch, epsca, rr, flx2, etpn, flx4 & & ) @@ -924,6 +943,7 @@ subroutine gfssflx_hafs &! --- endif + q1=q2+eta_kinematic*cp/rch !> - Noah LSM post-processing: !> - Calculate sensible heat (h) for return to parent model. @@ -1079,7 +1099,7 @@ subroutine alcalc & logical (kind=kind_phys), intent(in) :: snowng - real (kind=kind_phys), intent(out) :: snotime1 + real (kind=kind_phys), intent(inout) :: snotime1 ! --- outputs: @@ -1826,7 +1846,7 @@ subroutine penman ! --- inputs: & ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, & & cpx, cpfac, ssoil, q2, q2sat, dqsdt2, snowng, frzgra, & - & sncovr, sneqv, albedo, soldn, stc1, & + & sncovr, aoasis, sneqv, albedo, soldn, stc1, & ! --- outputs: & t24, etp, rch, epsca, rr, flx2, etpn, flx4 & & ) From 40a852afcb3f55b608477d051a2d1b568fd5b7c4 Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Tue, 28 Jan 2020 18:26:53 +0000 Subject: [PATCH 12/16] Adding more variables --- physics/sflx_hafs.meta | 387 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 378 insertions(+), 9 deletions(-) diff --git a/physics/sflx_hafs.meta b/physics/sflx_hafs.meta index 737a902bf..ca26c534e 100644 --- a/physics/sflx_hafs.meta +++ b/physics/sflx_hafs.meta @@ -615,15 +615,6 @@ kind = kind_phys intent = inout optional = F -[runoff] - standard_name = surface_runoff_flux - long_name = surface runoff flux - units = kg m-2 s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [cmm] standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land long_name = momentum exchange coefficient over land @@ -992,3 +983,381 @@ MKB Addition kind = kind_phys intent = inout optional = F +[albedo] + standard_name = surface_albedo_incl_snow_effect + long_name = surface albedo incl snow effect + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[eta] + standard_name = instantaneous_downward_latent_heat_flux + long_name = instantaneous downward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[eta_kinematic] + standard_name = actual_latent_heat_flux + long_name = actual latent heat flux + units = kg m-2 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[sheat] + standard_name = instantaneous_sensible_heat_flux + long_name = instantaneous sensible heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[ec] + standard_name = evaporation_from_canopy_intercepted_rainfall + long_name = evaporation from canopy intercepted rainfall + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[edir] + standard_name = direct_evaporation_from_soil + long_name = direct_evaporation_from_soil + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[et] + standard_name = transpiration_through_plant_canopy + long_name = transpiration through plant canopy + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[ett] + standard_name = total_plant_transpiration + long_name = total plant transpiration + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[esnow] + standard_name = sublimation_from_snowpack + long_name = sublimation from snowpack + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[drip] + standard_name = throughfall_of_precip_dew + long_name = through-fall of precip and or dew in excess of canopy water holding capacity + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dew] + standard_name = dewfall + long_name = dewfall or frostfall for t<273.15 + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[beta] + standard_name = ratio_of_actual_potential_evap + long_name = ratio of actual/potential evaporation + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[etp] + standard_name = potential_evap + long_name = potential evaporation + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[ssoil] + standard_name = upward_soil_heat_flux + long_name = upward soil heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[flx1] + standard_name = precip_snow_sfc_flux + long_name = precip snow sfc flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[flx2] + standard_name = freezing_rain_latent_heat_flux + long_name = freezing rain latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[flx3] + standard_name = phase_change_heat_flux_from_snow_melt + long_name = phase change heat flux from snow melt + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[flx4] + standard_name = energy_added_to_sensible_heat + long_name = energy added to sensible heat ua_phys + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[fvb] + standard_name = fraction_of_veg_with_snow_beneath + long_name = fraction of veg with snow beneath ua_phys + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[fbur] + standard_name = fraction_of_canopy_buried + long_name = fraction of canopy buried ua_phys + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[fgsn] + standard_name = fraction_of_ground_snow_cover + long_name = fraction of ground snow cover ua_phys + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[runoff1] + standard_name = surface_runoff + long_name = surface runoff not infiltrating sfc + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff2] + standard_name = sub_surface_runoff + long_name = sub surface runoff baseflow + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff3] + standard_name = excess_porosity + long_name = excess of porosity for a given soil layer + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snowmlt] + standard_name = surface_snow_melt + long_name = snow melt during timestep + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sncovr] + standard_name = fractional_snow_cover + long_name = fractional snow cover + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rc] + standard_name = canopy_resistance + long_name = canopy resistance + units = s m-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[pc] + standard_name = plant_coefficient + long_name = plant coefficient + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rsmin] + standard_name = min_canopy_resistance + long_name = min canopy resistance + units = s m-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[xlai] + standard_name = leaf_area_index + long_name = leaf_area_index + units = index + dimensions = () + type = real + kind = kind_phys + intent = inout + optional = F +[rcs] + standard_name = incoming_solar_rc_factor + long_name = incoming solar rc factor + units = index + dimensions = () + type = real + kind = kind_phys + intent = inout + optional = F +[rct] + standard_name = air_temperature_rc_factor + long_name = air temperature rc factor + units = index + dimensions = () + type = real + kind = kind_phys + intent = inout + optional = F +[rcq] + standard_name = atmospheric_vapor_pressure_deficit_rc_factor + long_name = atmospheric vapor pressure deficit rc factor + units = index + dimensions = () + type = real + kind = kind_phys + intent = inout + optional = F +[rcsoil] + standard_name = soil_moisture_rc_factor + long_name = soil moisture rc factor + units = index + dimensions = () + type = real + kind = kind_phys + intent = inout + optional = F +[soilw] + standard_name = soil_moisture_root_zone + long_name = available soil moisture in root zone + units = frac + dimensions = () + type = real + kind = kind_phys + intent = inout + optional = F +[soilm] + standard_name = total_soil_column_moisture_content + long_name = total soil column moisture content frozen and unfrozen + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[q1] + standard_name = effective_mixing_ratio_at_surface + long_name = effective mixing ratio at surface + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smav] + standard_name = soil_moisture_availability_for_each_layer + long_name = soil moisture availabilty for each layer + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwlt] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = wilting point (volumetric) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[smcref] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold (volumetric) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[smcdry] + standard_name = threshold_volume_fraction_of_dry_moisture_in_soil + long_name = dry soil moisture threshold where dry evap from top layer ends (volumetric) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[smcmax] + standard_name = porosity + long_name = saturated value of soil moisture (volumetric) + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F From 5890b233f45ed9ed95cb0bd987bbc1436192246a Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Tue, 28 Jan 2020 21:10:56 +0000 Subject: [PATCH 13/16] Adding HWRF surface layer CCPP complaint --- physics/sfc_diff_hafs.f | 725 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 725 insertions(+) create mode 100644 physics/sfc_diff_hafs.f diff --git a/physics/sfc_diff_hafs.f b/physics/sfc_diff_hafs.f new file mode 100644 index 000000000..3b68ac288 --- /dev/null +++ b/physics/sfc_diff_hafs.f @@ -0,0 +1,725 @@ +!> \file sfc_diff.f +!! this file contains the surface roughness length formulation based on +!! the surface sublayer scheme in +!! zeng and dickinson (1998) \cite zeng_and_dickinson_1998. + +!> this module contains the ccpp-compliant gfs surface layer scheme for +!!hafs. + module module_sfc_diff + + use machine , only : kind_phys + + use physcons, grav => con_g + real (kind=kind_phys), parameter :: ca=.4 ! ca - von karman constant + + contains + + subroutine sfc_diff_init + end subroutine sfc_diff_init + + subroutine sfc_diff_finalize + end subroutine sfc_diff_finalize + + subroutine sfc_diff_hafs(im,ps,u1,v1,t1,q1,z1, &!intent(in) + & prsl1,prslki,ddvel, &!intent(in) + & sigmaf,vegtype,shdmax,ivegsrc, &!intent(in) + & z0pert,ztpert, &! mg, sfc-perts !intent(in) + & flag_iter,redrag, &!intent(in) + & u10m,v10m,sfc_z0_type, &!wang,z0 type !intent(in) + & wet,dry,icy, &!intent(in) + & tskin, tsurf, snwdph, z0rl, ustar, + & cm, ch, rb, stress, fm, fh, fm10, fh2, + & wind) &!intent(out) +! + use funcphys, only : fpvs + use physcons, rvrdm1 => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! +! 1 - land, 2 - ice, 3 - water +! -------- -------- --------- + integer, intent(in) :: im, ivegsrc + integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean + + integer, dimension(im), intent(in) :: vegtype + + logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) + logical, dimension(im), intent(in) :: flag_iter, dry, wet, icy + + real(kind=kind_phys), dimension(im), intent(in) :: u10m,v10m + real(kind=kind_phys), dimension(im), intent(in) :: + & ps,u1,v1,t1,q1,z1,prsl1,prslki,ddvel, & + & sigmaf,shdmax, & + & z0pert,ztpert ! mg, sfc-perts + real(kind=kind_phys), dimension(im,3), intent(in) :: & + & tskin, tsurf, snwdph + + real(kind=kind_phys), dimension(im,3), intent(inout) :: & + & z0rl, ustar + +! 1 - land, 2 - ice, 3 - water +! -------- -------- --------- + real(kind=kind_phys), dimension(im,3), intent(out) :: & + & cm, ch, rb, stress, fm, fh, fm10, fh2 + real(kind=kind_phys), dimension(im), intent(out) :: wind +! +! locals +! + real(kind=kind_phys), dimension(im) :: wind10m + + integer i +! + real(kind=kind_phys) :: qs1, rat, thv1, restar, & + & czilc, tem1, tem2 + + real(kind=kind_phys) :: tvs_ocn, tvs_lnd, tvs_ice, & + & z0_ocn, z0_lnd, z0_ice, & + & z0max_ocn,z0max_lnd,z0max_ice, & + & ztmax_ocn,ztmax_lnd,ztmax_ice +! + real(kind=kind_phys), parameter :: + & charnock=.014, z0s_max=.317e-2, & ! a limiting value at high winds over sea + & vis=1.4e-5, rnu=1.51e-5, visi=1.0/vis, & + & log01=log(0.01), log05=log(0.05), log07=log(0.07) + +! parameter (charnock=.014,ca=.4)!c ca is the von karman constant +! parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041) +! parameter (a0p=-7.941,a1p=24.75,b1p=-8.705,b2p=7.899,vis=1.4e-5) + +! real(kind=kind_phys) aa1,bb1,bb2,cc,cc1,cc2,arnu +! parameter (aa1=-1.076,bb1=.7045,cc1=-.05808) +! parameter (bb2=-.1954,cc2=.009999) +! parameter (arnu=.135*rnu) +! +! z0s_max=.196e-2 for u10_crit=25 m/s +! z0s_max=.317e-2 for u10_crit=30 m/s +! z0s_max=.479e-2 for u10_crit=35 m/s +! +! mbek -- toga-coare flux algorithm +! parameter (rnu=1.51e-5,arnu=0.11*rnu) +! +! initialize variables. all units are supposedly m.k.s. unless specified +! ps is in pascals, wind is wind speed, +! surface roughness length is converted to m from cm +! + +! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type + + do i=1,im + ztmax_ocn = 0.0 ; ztmax_lnd = 0.0 ; ztmax_ice = 0.0 + tvs_lnd = 0.0 ; tvs_ice = 0.0 ; tvs_ocn = 0.0 + + wind10m(i) = max(sqrt( u10m(i)*u10m(i) + v10m(i)*v10m(i)), & + & 1.0) + + + if(flag_iter(i)) then + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + & + max(0.0, min(ddvel(i), 30.0)), 1.0) + tem1 = 1.0 + rvrdm1 * max(q1(i),1.e-8) + thv1 = t1(i) * prslki(i) * tem1 + if (dry(i)) tvs_lnd = 0.5 * (tsurf(i,1)+tskin(i,1)) * tem1 + if (icy(i)) tvs_ice = 0.5 * (tsurf(i,2)+tskin(i,2)) * tem1 + if (wet(i)) tvs_ocn = 0.5 * (tsurf(i,3)+tskin(i,3)) * tem1 + + qs1 = fpvs(t1(i)) + qs1 = max(1.0e-8, eps * qs1 / (prsl1(i) + epsm1 * qs1)) + + z0_lnd = 0.01 * z0rl(i,1) + z0max_lnd = max(1.0e-6, min(z0_lnd,z1(i))) + z0_ice = 0.01 * z0rl(i,2) + z0max_ice = max(1.0e-6, min(z0_ice,z1(i))) + z0_ocn = 0.01 * z0rl(i,3) + z0max_ocn = max(1.0e-6, min(z0_ocn,z1(i))) + +! compute stability dependent exchange coefficients +! this portion of the code is presently suppressed +! + + if (wet(i)) then ! some open ocean + ustar(i,3) = sqrt(grav * z0_ocn / charnock) + +!** test xubin's new z0 + +! ztmax = z0max + + restar = max(ustar(i,3)*z0max_ocn*visi, 0.000001) + +! restar = log(restar) +! restar = min(restar,5.) +! restar = max(restar,-5.) +! rat = aa1 + (bb1 + cc1*restar) * restar +! rat = rat / (1. + (bb2 + cc2*restar) * restar)) +! rat taken from zeng, zhao and dickinson 1997 + + rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) + ztmax_ocn = z0max_ocn * exp(-rat) + + if (sfc_z0_type == 6) then + call znot_t_v6(wind10m(i),ztmax_ocn) ! 10-m wind,m/s, ztmax(m) + else if (sfc_z0_type == 7) then + call znot_t_v7(wind10m(i),ztmax_ocn) ! 10-m wind,m/s, ztmax(m) + else if (sfc_z0_type .ne. 0) then + write(0,*)'no option for sfc_z0_type=',sfc_z0_type + stop + endif + + endif ! open ocean + + if (dry(i) .or. icy(i)) then ! over land or sea ice +!** xubin's new z0 over land and sea ice + tem1 = 1.0 - shdmax(i) + tem2 = tem1 * tem1 + tem1 = 1.0 - tem2 + + if( ivegsrc == 1 ) then + + if (vegtype(i) == 10) then + z0max_lnd = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 6) then + z0max_lnd = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 7) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max_lnd = 0.01 + elseif (vegtype(i) == 16) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max_lnd = 0.01 + else + z0max_lnd = exp( tem2*log01 + tem1*log(z0max_lnd) ) + endif + + elseif (ivegsrc == 2 ) then + + if (vegtype(i) == 7) then + z0max_lnd = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 8) then + z0max_lnd = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 9) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max_lnd = 0.01 + elseif (vegtype(i) == 11) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max_lnd = 0.01 + else + z0max_lnd = exp( tem2*log01 + tem1*log(z0max_lnd) ) + endif + + endif ! over land or sea ice + + z0max_ice = z0max_lnd + +! mg, sfc-perts: add surface perturbations to z0max over land + if (dry(i) .and. z0pert(i) /= 0.0 ) then + z0max_lnd = z0max_lnd * (10.**z0pert(i)) + endif + + z0max_lnd = max(z0max_lnd,1.0e-6) + z0max_ice = max(z0max_ice,1.0e-6) + +! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil + czilc = 0.8 + + tem1 = 1.0 - sigmaf(i) + ztmax_lnd = z0max_lnd*exp( - tem1*tem1 + & * czilc*ca*sqrt(ustar(i,1)*(0.01/1.5e-05))) + ztmax_ice = z0max_ice*exp( - tem1*tem1 + & * czilc*ca*sqrt(ustar(i,2)*(0.01/1.5e-05))) + + +! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land + if (dry(i) .and. ztpert(i) /= 0.0) then + ztmax_lnd = ztmax_lnd * (10.**ztpert(i)) + endif + + + endif ! end of if(sfctype flags) then + + ztmax_ocn = max(ztmax_ocn,1.0e-6) + ztmax_lnd = max(ztmax_lnd,1.0e-6) + ztmax_ice = max(ztmax_ice,1.0e-6) + +! bwg begin "stability" block, 2019-03-23 + if (wet(i)) then ! some open ocean + call stability & +! --- inputs: + & (z1(i),snwdph(i,3),thv1,wind(i), & + & z0max_ocn,ztmax_ocn,tvs_ocn, & +! --- outputs: + & rb(i,3), fm(i,3), fh(i,3), fm10(i,3), fh2(i,3), & + & cm(i,3), ch(i,3), stress(i,3), ustar(i,3)) + endif ! open ocean points + + if (dry(i)) then ! some land + call stability & +! --- inputs: + & (z1(i),snwdph(i,1),thv1,wind(i), & + & z0max_lnd,ztmax_lnd,tvs_lnd, & +! --- outputs: + & rb(i,1), fm(i,1), fh(i,1), fm10(i,1), fh2(i,1), & + & cm(i,1), ch(i,1), stress(i,1), ustar(i,1)) + endif ! dry points + + if (icy(i)) then ! some ice + call stability & +! --- inputs: + & (z1(i),snwdph(i,2),thv1,wind(i), & + & z0max_ice,ztmax_ice,tvs_ice, +! --- outputs: + & rb(i,2), fm(i,2), fh(i,2), fm10(i,2), fh2(i,2), & + & cm(i,2), ch(i,2), stress(i,2), ustar(i,2)) + endif ! icy points + +! bwg: everything from here to end of subroutine was after +! the stuff now put into "stability" + +! +! update z0 over ocean +! + if (wet(i)) then + z0_ocn = (charnock / grav) * ustar(i,3) * ustar(i,3) + +! mbek -- toga-coare flux algorithm +! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) +! new implementation of z0 +! cc = ustar(i) * z0 / rnu +! pp = cc / (1. + cc) +! ff = grav * arnu / (charnock * ustar(i) ** 3) +! z0 = arnu / (ustar(i) * ff ** pp) + + if (redrag) then + z0rl(i,3) = 100.0 * max(min(z0_ocn, z0s_max), 1.e-7) + else + z0rl(i,3) = 100.0 * max(min(z0_ocn,.1), 1.e-7) + endif + + if (sfc_z0_type == 6) then ! wang + call znot_m_v6(wind10m(i),z0_ocn) ! wind, m/s, z0, m + z0rl(i,3) = 100.0 * z0_ocn ! cm + endif !wang + if (sfc_z0_type == 7) then ! wang + call znot_m_v7(wind10m(i),z0_ocn) ! wind, m/s, z0, m + z0rl(i,3) = 100.0 * z0_ocn ! cm + endif !wang + + + endif ! end of if(open ocean) + endif ! end of if(flagiter) loop + enddo + + return + end subroutine sfc_diff + + +!---------------------------------------- + subroutine stability +!........................................ +! --- inputs: + & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, & +! --- outputs: + & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) +!----- + +! --- inputs: + real(kind=kind_phys), intent(in) :: & + & z1, snwdph, thv1, wind, z0max, ztmax, tvs + +! --- outputs: + real(kind=kind_phys), intent(out) :: & + & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar + +! --- locals: + real(kind=kind_phys), parameter :: alpha=5., a0=-3.975, & + & a1=12.32, alpha4=4.0*alpha, & + & b1=-7.755, b2=6.041, alpha2=alpha+alpha, beta=1.0,& + & a0p=-7.941, a1p=24.75, b1p=-8.705, b2p=7.899, & + & ztmin1=-999.0 + + real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, & + & hl1, hl12, pm, ph, pm10, ph2, & + & z1i, & + & fms, fhs, hl0, hl0inf, hlinf, & + & hl110, hlt, hltinf, olinf, & + & tem1, tem2, ztmax1 + + z1i = 1.0 / z1 + + tem1 = z0max/z1 + if (abs(1.0-tem1) > 1.0e-6) then + ztmax1 = - beta*log(tem1)/(alpha2*(1.-tem1)) + else + ztmax1 = 99.0 + endif + if( z0max < 0.05 .and. snwdph < 10.0 ) ztmax1 = 99.0 + +! compute stability indices (rb and hlinf) + + dtv = thv1 - tvs + adtv = max(abs(dtv),0.001) + dtv = sign(1.,dtv) * adtv + rb = max(-5000.0, (grav+grav) * dtv * z1 + & / ((thv1 + tvs) * wind * wind)) + tem1 = 1.0 / z0max + tem2 = 1.0 / ztmax + fm = log((z0max+z1) * tem1) + fh = log((ztmax+z1) * tem2) + fm10 = log((z0max+10.)* tem1) + fh2 = log((ztmax+2.) * tem2) + hlinf = rb * fm * fm / fh + hlinf = min(max(hlinf,ztmin1),ztmax1) +! +! stable case +! + if (dtv >= 0.0) then + hl1 = hlinf + if(hlinf > .25) then + tem1 = hlinf * z1i + hl0inf = z0max * tem1 + hltinf = ztmax * tem1 + aa = sqrt(1. + alpha4 * hlinf) + aa0 = sqrt(1. + alpha4 * hl0inf) + bb = aa + bb0 = sqrt(1. + alpha4 * hltinf) + pm = aa0 - aa + log( (aa + 1.)/(aa0 + 1.) ) + ph = bb0 - bb + log( (bb + 1.)/(bb0 + 1.) ) + fms = fm - pm + fhs = fh - ph + hl1 = fms * fms * rb / fhs + hl1 = min(max(hl1, ztmin1), ztmax1) + endif +! +! second iteration +! + tem1 = hl1 * z1i + hl0 = z0max * tem1 + hlt = ztmax * tem1 + aa = sqrt(1. + alpha4 * hl1) + aa0 = sqrt(1. + alpha4 * hl0) + bb = aa + bb0 = sqrt(1. + alpha4 * hlt) + pm = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + ph = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + aa = sqrt(1. + alpha4 * hl110) + pm10 = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12,ztmin1),ztmax1) +! aa = sqrt(1. + alpha4 * hl12) + bb = sqrt(1. + alpha4 * hl12) + ph2 = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) +! +! unstable case - check for unphysical obukhov length +! + else ! dtv < 0 case + olinf = z1 / hlinf + tem1 = 50.0 * z0max + if(abs(olinf) <= tem1) then + hlinf = -z1 / tem1 + hlinf = min(max(hlinf,ztmin1),ztmax1) + endif +! +! get pm and ph +! + if (hlinf >= -0.5) then + hl1 = hlinf + pm = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + ph = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = (a0 + a1*hl110) * hl110 / (1.+(b1+b2*hl110)*hl110) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = (a0p + a1p*hl12) * hl12 / (1.+(b1p+b2p*hl12)*hl12) + else ! hlinf < 0.05 + hl1 = -hlinf + tem1 = 1.0 / sqrt(hl1) + pm = log(hl1) + 2. * sqrt(tem1) - .8776 + ph = log(hl1) + .5 * tem1 + 1.386 +! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 +! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776 +! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = log(hl12) + 0.5 / sqrt(hl12) + 1.386 +! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 + endif + + endif ! end of if (dtv >= 0 ) then loop +! +! finish the exchange coefficient computation to provide fm and fh +! + fm = fm - pm + fh = fh - ph + fm10 = fm10 - pm10 + fh2 = fh2 - ph2 + cm = ca * ca / (fm * fm) + ch = ca * ca / (fm * fh) + tem1 = 0.00001/z1 + cm = max(cm, tem1) + ch = max(ch, tem1) + stress = cm * wind * wind + ustar = sqrt(stress) + + return +!................................. + end subroutine stability +!--------------------------------- + + +!! add fitted z0,zt curves for hurricane application (used in hwrf/hmon) +!! weiguo wang, 2019-0425 + + subroutine znot_m_v6(uref,znotm) + implicit none +! calculate areodynamical roughness over water with input 10-m wind +! for low-to-moderate winds, try to match the cd-u10 relationship from coare v3.5 (edson et al. 2013) +! for high winds, try to fit available observational data +! +! bin liu, noaa/ncep/emc 2017 +! +! uref(m/s) : wind speed at 10-m height +! znotm(meter): areodynamical roughness scale over water +! + + real (kind=kind_phys), intent(in) :: uref + real (kind=kind_phys), intent(out):: znotm + real :: p13, p12, p11, p10 + real :: p25, p24, p23, p22, p21, p20 + real :: p35, p34, p33, p32, p31, p30 + real :: p40 + + real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, & + & p12 = 2.855780863283819e-01 p11 = -1.597898515251717e+00, & + & p10 = -8.396975715683501e+00, & + + & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, & + & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, & + & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, & + + & p35 = 1.840430200185075e-07, p34 = -2.793849676757154e-05, & + & p33 = 1.735308193700643e-03, p32 = -6.139315534216305e-02, & + & p31 = 1.255457892775006e+00, p30 = -1.663993561652530e+01, & + + & p40 = 4.579369142033410e-04 + + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp( p10 + p11*uref + p12*uref**2 + & + & p13*uref**3) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + & + & p22*uref**2 + p21*uref + p20 + elseif (uref > 15.7 .and. uref <= 53.0) then + znotm = exp( p35*uref**5 + p34*uref**4 + & + & p33*uref**3 + p32*uref**2 + p31*uref + p30 ) + elseif ( uref > 53.0) then + znotm = p40 + else + print*, 'wrong input uref value:',uref + endif + + end subroutine znot_m_v6 + + subroutine znot_t_v6(uref,znott) + implicit none +! calculate scalar roughness over water with input 10-m wind +! for low-to-moderate winds, try to match the ck-u10 relationship from coare algorithm +! for high winds, try to retain the ck-u10 relationship of fy2015 hwrf +! +! bin liu, noaa/ncep/emc 2017 +! +! uref(m/s) : wind speed at 10-m height +! znott(meter): scalar roughness scale over water +! + + real (kind=kind_phys), intent(in) :: uref + real (kind=kind_phys), intent(out):: znott + + real :: p00 + real :: p15, p14, p13, p12, p11, p10 + real :: p25, p24, p23, p22, p21, p20 + real :: p35, p34, p33, p32, p31, p30 + real :: p45, p44, p43, p42, p41, p40 + real :: p56, p55, p54, p53, p52, p51, p50 + real :: p60 + + real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, & + + & p15 = -9.144581627678278e-10, p14 = 7.020346616456421e-08, & + & p13 = -2.155602086883837e-06, p12 = 3.333848806567684e-05, & + & p11 = -2.628501274963990e-04, p10 = 8.634221567969181e-04, & + + & p25 = -8.654513012535990e-12, p24 = 1.232380050058077e-09, & + & p23 = -6.837922749505057e-08, p22 = 1.871407733439947e-06, & + & p21 = -2.552246987137160e-05, p20 = 1.428968311457630e-04, & + + & p35 = 3.207515102100162e-12, p34 = -2.945761895342535e-10, & + & p33 = 8.788972147364181e-09, p32 = -3.814457439412957e-08, & + & p31 = -2.448983648874671e-06, p30 = 3.436721779020359e-05, & + + & p45 = -3.530687797132211e-11, p44 = 3.939867958963747e-09, & + & p43 = -1.227668406985956e-08, p42 = -1.367469811838390e-05, & + & p41 = 5.988240863928883e-04, p40 = -7.746288511324971e-03, & + + & p56 = -1.187982453329086e-13, p55 = 4.801984186231693e-11, & + & p54 = -8.049200462388188e-09, p53 = 7.169872601310186e-07, & + & p52 = -3.581694433758150e-05, p51 = 9.503919224192534e-04, & + & p50 = -1.036679430885215e-02, + + & p60 = 4.751256171799112e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p15*uref**5 + p14*uref**4 + p13*uref**3 & + & + p12*uref**2 + p11*uref + p10 + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p25*uref**5 + p24*uref**4 + p23*uref**3 & + & + p22*uref**2 + p21*uref + p20 + elseif (uref > 21.6 .and. uref <= 42.2) then + znott = p35*uref**5 + p34*uref**4 + p33*uref**3 & + & + p32*uref**2 + p31*uref + p30 + elseif ( uref > 42.2 .and. uref <= 53.3) then + znott = p45*uref**5 + p44*uref**4 + p43*uref**3 & + & + p42*uref**2 + p41*uref + p40 + elseif ( uref > 53.3 .and. uref <= 80.0) then + znott = p56*uref**6 + p55*uref**5 + p54*uref**4 & + & + p53*uref**3 + p52*uref**2 + p51*uref + p50 + elseif ( uref > 80.0) then + znott = p60 + else + print*, 'wrong input uref value:',uref + endif + + end subroutine znot_t_v6 + + + subroutine znot_m_v7(uref,znotm) + implicit none +! calculate areodynamical roughness over water with input 10-m wind +! for low-to-moderate winds, try to match the cd-u10 relationship from coare v3.5 (edson et al. 2013) +! for high winds, try to fit available observational data +! comparing to znot_t_v6, slightly decrease cd for higher wind speed +! +! bin liu, noaa/ncep/emc 2018 +! +! uref(m/s) : wind speed at 10-m height +! znotm(meter): areodynamical roughness scale over water +! + + real (kind=kind_phys), intent(in) :: uref + real (kind=kind_phys), intent(out):: znotm + real :: p13, p12, p11, p10 + real :: p25, p24, p23, p22, p21, p20 + real :: p35, p34, p33, p32, p31, p30 + real :: p40 + + real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, & + & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00, & + & p10 = -8.396975715683501e+00, & + + & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, & + & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, & + & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, & + + + & p35 = 1.897534489606422e-07, p34 = -3.019495980684978e-05, & + & p33 = 1.931392924987349e-03, p32 = -6.797293095862357e-02, & + & p31 = 1.346757797103756e+00, p30 = -1.707846930193362e+01, & + + & p40 = 3.371427455376717e-04 + + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + & + & p22*uref**2 + p21*uref + p20 + elseif (uref > 15.7 .and. uref <= 53.0) then + znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 + & + & p32*uref**2 + p31*uref + p30 ) + elseif ( uref > 53.0) then + znotm = p40 + else + print*, 'wrong input uref value:',uref + endif + + end subroutine znot_m_v7 + subroutine znot_t_v7(uref,znott) + implicit none +! calculate scalar roughness over water with input 10-m wind +! for low-to-moderate winds, try to match the ck-u10 relationship from coare algorithm +! for high winds, try to retain the ck-u10 relationship of fy2015 hwrf +! to be compatible with the slightly decreased cd for higher wind speed +! +! bin liu, noaa/ncep/emc 2018 +! +! uref(m/s) : wind speed at 10-m height +! znott(meter): scalar roughness scale over water +! + + real (kind=kind_phys), intent(in) :: uref + real (kind=kind_phys), intent(out):: znott + + real :: p00 + real :: p15, p14, p13, p12, p11, p10 + real :: p25, p24, p23, p22, p21, p20 + real :: p35, p34, p33, p32, p31, p30 + real :: p45, p44, p43, p42, p41, p40 + real :: p56, p55, p54, p53, p52, p51, p50 + real :: p60 + + real(kind=kind_phys), parameter ::p00 = 1.100000000000000e-04, & + + & p15 = -9.193764479895316e-10, p14 = 7.052217518653943e-08, & + & p13 = -2.163419217747114e-06, p12 = 3.342963077911962e-05, & + & p11 = -2.633566691328004e-04, p10 = 8.644979973037803e-04, & + + & p25 = -9.402722450219142e-12, p24 = 1.325396583616614e-09, & + & p23 = -7.299148051141852e-08, p22 = 1.982901461144764e-06, & + & p21 = -2.680293455916390e-05, p20 = 1.484341646128200e-04, & + + & p35 = 7.921446674311864e-12, p34 = -1.019028029546602e-09, & + & p33 = 5.251986927351103e-08, p32 = -1.337841892062716e-06, & + & p31 = 1.659454106237737e-05, p30 = -7.558911792344770e-05, & + + & p45 = -2.694370426850801e-10, p44 = 5.817362913967911e-08, & + & p43 = -5.000813324746342e-06, p42 = 2.143803523428029e-04, & + & p41 = -4.588070983722060e-03, p40 = 3.924356617245624e-02, & + + & p56 = -1.663918773476178e-13, p55 = 6.724854483077447e-11, & + & p54 = -1.127030176632823e-08, p53 = 1.003683177025925e-06, & + & p52 = -5.012618091180904e-05, p51 = 1.329762020689302e-03, & + & p50 = -1.450062148367566e-02, + + & p60 = 6.840803042788488e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + + & p12*uref**2 + p11*uref + p10 + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + + & p22*uref**2 + p21*uref + p20 + elseif (uref > 21.6 .and. uref <= 42.6) then + znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + + & p32*uref**2 + p31*uref + p30 + elseif ( uref > 42.6 .and. uref <= 53.0) then + znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + + & p42*uref**2 + p41*uref + p40 + elseif ( uref > 53.0 .and. uref <= 80.0) then + znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + + & p53*uref**3 + p52*uref**2 + p51*uref + p50 + elseif ( uref > 80.0) then + znott = p60 + else + print*, 'wrong input uref value:',uref + endif + + end subroutine znot_t_v7 + + +!--------------------------------- + end module module_sfc_diff From 66ef4ee616a6ff8440aa4dd48e22a8ee9badf3eb Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Tue, 28 Jan 2020 22:09:50 +0000 Subject: [PATCH 14/16] Updating the code to make it CCPP complaint --- physics/sfc_diff_hafs.f | 57 +++++++++++++++++++++++++++++++---------- 1 file changed, 44 insertions(+), 13 deletions(-) diff --git a/physics/sfc_diff_hafs.f b/physics/sfc_diff_hafs.f index 3b68ac288..3c5efff64 100644 --- a/physics/sfc_diff_hafs.f +++ b/physics/sfc_diff_hafs.f @@ -220,9 +220,9 @@ subroutine sfc_diff_hafs(im,ps,u1,v1,t1,q1,z1, &!intent(in) czilc = 0.8 tem1 = 1.0 - sigmaf(i) - ztmax_lnd = z0max_lnd*exp( - tem1*tem1 + ztmax_lnd = z0max_lnd*exp( - tem1*tem1 & & * czilc*ca*sqrt(ustar(i,1)*(0.01/1.5e-05))) - ztmax_ice = z0max_ice*exp( - tem1*tem1 + ztmax_ice = z0max_ice*exp( - tem1*tem1 & & * czilc*ca*sqrt(ustar(i,2)*(0.01/1.5e-05))) @@ -307,7 +307,9 @@ subroutine sfc_diff_hafs(im,ps,u1,v1,t1,q1,z1, &!intent(in) enddo return +!................................ end subroutine sfc_diff +!................................ !---------------------------------------- @@ -472,7 +474,11 @@ end subroutine stability !! add fitted z0,zt curves for hurricane application (used in hwrf/hmon) !! weiguo wang, 2019-0425 - subroutine znot_m_v6(uref,znotm) + subroutine znot_m_v6 & +! inputs + & (uref, & +! outputs + & znotm) implicit none ! calculate areodynamical roughness over water with input 10-m wind ! for low-to-moderate winds, try to match the cd-u10 relationship from coare v3.5 (edson et al. 2013) @@ -520,9 +526,16 @@ subroutine znot_m_v6(uref,znotm) print*, 'wrong input uref value:',uref endif + return +!................................. end subroutine znot_m_v6 +!................................. subroutine znot_t_v6(uref,znott) +! inputs + & (uref, +! outputs + & znott) implicit none ! calculate scalar roughness over water with input 10-m wind ! for low-to-moderate winds, try to match the ck-u10 relationship from coare algorithm @@ -593,10 +606,16 @@ subroutine znot_t_v6(uref,znott) print*, 'wrong input uref value:',uref endif + return +!................................. end subroutine znot_t_v6 +!................................. - - subroutine znot_m_v7(uref,znotm) + subroutine znot_m_v7 & +! inputs + & (uref, & +! outputs + & znotm) implicit none ! calculate areodynamical roughness over water with input 10-m wind ! for low-to-moderate winds, try to match the cd-u10 relationship from coare v3.5 (edson et al. 2013) @@ -645,9 +664,17 @@ subroutine znot_m_v7(uref,znotm) print*, 'wrong input uref value:',uref endif + return +!................................. end subroutine znot_m_v7 - subroutine znot_t_v7(uref,znott) - implicit none +!................................. + + subroutine znot_t_v7 & +! inputs + & (uref, & +! outputs + & znott) + ! calculate scalar roughness over water with input 10-m wind ! for low-to-moderate winds, try to match the ck-u10 relationship from coare algorithm ! for high winds, try to retain the ck-u10 relationship of fy2015 hwrf @@ -659,6 +686,7 @@ subroutine znot_t_v7(uref,znott) ! znott(meter): scalar roughness scale over water ! + implicit none real (kind=kind_phys), intent(in) :: uref real (kind=kind_phys), intent(out):: znott @@ -698,19 +726,19 @@ subroutine znot_t_v7(uref,znott) if (uref >= 0.0 .and. uref < 5.9 ) then znott = p00 elseif (uref >= 5.9 .and. uref <= 15.4) then - znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + + znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + & & p12*uref**2 + p11*uref + p10 elseif (uref > 15.4 .and. uref <= 21.6) then - znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + + znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + & & p22*uref**2 + p21*uref + p20 elseif (uref > 21.6 .and. uref <= 42.6) then - znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + + znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + & & p32*uref**2 + p31*uref + p30 elseif ( uref > 42.6 .and. uref <= 53.0) then - znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + + znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + & & p42*uref**2 + p41*uref + p40 elseif ( uref > 53.0 .and. uref <= 80.0) then - znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + + znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + & & p53*uref**3 + p52*uref**2 + p51*uref + p50 elseif ( uref > 80.0) then znott = p60 @@ -718,7 +746,10 @@ subroutine znot_t_v7(uref,znott) print*, 'wrong input uref value:',uref endif - end subroutine znot_t_v7 + return +!................................. + end subroutine znot_t_v7 +!................................. !--------------------------------- From 3c87cd9de6cb4c7c280a0767048d1b314274f28c Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Wed, 29 Jan 2020 00:19:17 +0000 Subject: [PATCH 15/16] Adding sfc_diff_hefas.meta --- physics/sfc_diff_hafs.meta | 398 +++++++++++++++++++++++++++++++++++++ 1 file changed, 398 insertions(+) create mode 100644 physics/sfc_diff_hafs.meta diff --git a/physics/sfc_diff_hafs.meta b/physics/sfc_diff_hafs.meta new file mode 100644 index 000000000..79d6f8994 --- /dev/null +++ b/physics/sfc_diff_hafs.meta @@ -0,0 +1,398 @@ +[ccpp-arg-table] + name = sfc_diff_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[rvrdm1] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ps] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[u1] + standard_name = x_wind_at_lowest_model_level + long_name = 1st model layer u wind speed + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind_at_lowest_model_level + long_name = 1st model layer v wind speed + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = 1st model layer air temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = 1st model layer specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[z1] + standard_name = height_above_ground_at_lowest_model_layer + long_name = height above ground at 1st model layer + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = Model layer 1 mean pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsik1] + standard_name = dimensionless_exner_function_at_lowest_model_interface + long_name = dimensionless Exner function at the ground surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk1] + standard_name = dimensionless_exner_function_at_lowest_model_layer + long_name = dimensionless Exner function at the lowest model layer + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractnl cover of green veg + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[z0pert] + standard_name = perturbation_of_momentum_roughness_length + long_name = perturbation of momentum roughness length + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ztpert] + standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio + long_name = perturbation of heat to momentum roughness length ratio + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[redrag] + standard_name = flag_for_reduced_drag_coefficient_over_sea + long_name = flag for reduced drag coefficient over sea + units = flag + dimensions = () + type = logical + intent = in + optional = F +[u10m] + standard_name = x_wind_at_10m + long_name = 10 meter u wind speed + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v10m] + standard_name = y_wind_at_10m + long_name = 10 meter v wind speed + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfc_z0_type] + standard_name = flag_for_surface_roughness_option_over_ocean + long_name = surface roughness options over ocean + units = flag + dimensions = () + type = integer + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[tskin] + standard_name = surface_skin_temperature_interstitial + long_name = surface skin temperature over 1-land 2-ice 3-ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration + long_name = surface skin temperature after iteration over 1-land 2-ice 3-ocean + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent + long_name = water equivalent snow depth 1-land 2-ice 3-ocean + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[z0rl] + standard_name = surface_roughness_length_interstitial + long_name = surface roughness length over 1-land 2-ice 3-ocean (temporary use as interstitial) + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar] + standard_name = surface_friction_velocity + long_name = surface friction velocity over 1-land 2-ice 3-ocean + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air + long_name = surface exchange coeff for momentum over 1-land 2-ice 3-ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture over 1-land 2-ice 3-ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rb] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface over 1-land 2-ice 3-ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stress] + standard_name = surface_wind_stress + long_name = surface wind stress over 1-land 2-ice 3-ocean + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum + long_name = Monin-Obukhov similarity function for momentum over 1-land 2-ice 3-ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh] + standard_name = Monin_Obukhov_similarity_function_for_heat + long_name = Monin-Obukhov similarity function for heat over 1-land 2-ice 3-ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m + long_name = Monin-Obukhov similarity parameter for momentum at 10m over 1-land 2-ice 3-ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m + long_name = Monin-Obukhov similarity parameter for heat at 2m over 1-land 2-ice 3-ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From f93cd6a0fcd0dc54cefb34a2df62e26b158897ba Mon Sep 17 00:00:00 2001 From: Mrinal Biswas Date: Wed, 29 Jan 2020 00:19:52 +0000 Subject: [PATCH 16/16] Adding varaible descp --- physics/sfc_diff_hafs.f | 89 +++++++++++++++++++++++++++++++++++++++-- 1 file changed, 86 insertions(+), 3 deletions(-) diff --git a/physics/sfc_diff_hafs.f b/physics/sfc_diff_hafs.f index 3c5efff64..62ead6e97 100644 --- a/physics/sfc_diff_hafs.f +++ b/physics/sfc_diff_hafs.f @@ -20,6 +20,88 @@ end subroutine sfc_diff_init subroutine sfc_diff_finalize end subroutine sfc_diff_finalize +!> \defgroup GFS_diff_main GFS Surface Layer Scheme Module +!> @{ +!> \brief This subroutine calculates surface roughness length. +!! +!! This subroutine includes the surface roughness length formulation +!! based on the surface sublayer scheme in +!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998. +!> \section arg_table_sfc_diff_run Argument Table +!! \htmlinclude sfc_diff_run.html +!! +!> \section general_diff GFS Surface Layer Scheme General Algorithm +!! - Calculate the thermal roughness length formulation over the ocean +!(see eq. (25) and (26) +!! in Zeng et al. (1998) \cite zeng_et_al_1998). +!! - Calculate Zeng's momentum roughness length formulation over land +!and sea ice. +!! - Calculate the new vegetation-dependent formulation of thermal +!roughness length +!! (Zheng et al.(2009) \cite zheng_et_al_2009). +!! Zheng et al. (2009) \cite zheng_et_al_2009 proposed a new formulation +!on +!! \f$ln(Z_{0m}^,/Z_{0t})\f$ as follows: +!! \f[ +!! ln(Z_{0m}^,/Z_{0t})=(1-GVF)^2C_{zil}k(u*Z_{0g}/\nu)^{0.5} +!! \f] +!! where \f$Z_{0m}^,\f$ is the effective momentum roughness length +!! computed in the following equation for each grid, \f$Z_{0t}\f$ +!! is the roughness lenghth for heat, \f$C_{zil}\f$ is a coefficient +!! (taken as 0.8), k is the Von Karman constant (0.4), +!! \f$\nu=1.5\times10^{-5}m^{2}s^{-1}\f$ is the molecular viscosity, +!! \f$u*\f$ is the friction velocity, and \f$Z_{0g}\f$ is the bare +!! soil roughness length for momentum (taken as 0.01). +!! \n In order to consider the convergence of \f$Z_{0m}\f$ between +!! fully vegetated and bare soil, the effective \f$Z_{0m}^,\f$ is +!! computed: +!! \f[ +!! +!\ln(Z_{0m}^,)=(1-GVF)^{2}\ln(Z_{0g})+\left[1-(1-GVF)^{2}\right]\ln(Z_{0m}) +!!\f] +!! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and +!\f$stress\f$ as inputs of other \a sfc schemes. +!! +!!\param[in] ps real, surface air pressure (\f$Pa\f$) +!!\param[in] u1 real, zonal wind velocity (\f$m/s\f$) +!!\param[in] v1 real, meridional wind velocity (\f$m/s\f$) +!!\param[in] t1 real, air temperature (\f$K\f$) +!!\param[in] q1 real, water vapor mixing ratio (\f$kg/kg\f$) +!!\param[in] z1 real, height above ground (\f$m\f$) +!!\param[in] prsl1 real, air pressure at lowest level (\f$Pa\f$) +!!\param[in] prslki real, ratio of exner func bet midlayer and +!! interface at lowest model layer +!!\param[in] ddvel real, (\f$\f$) +!!\param[in] sigmaf real, real fractional cover of green vegetation bounded on the bottom(\f$frac\f$) +!!\param[in] vegtyp integer, vegetation type classification +!!\param[in] shdmax real, max areal coverage of green veg (fraction) +!!\param[in] ivegsrc integer, vegetation type dataset choice +!!\param[in] z0pert real, perturbation of momentum roughness length +!!\param[in] ztpert real, perturbation of heat to momentum roughness length ratio (frac) +!!\param[in] flag_iter flag, flag for perturbation +!!\param[in] redrag logical, flag for reduced drag coefficient over sea +!!\param[in] u10m real, zonal wind at 10 m (\f$m/s\f$) +!!\param[in] v10m real, meridional wind at 10 m (\f$m/s\f$) +!!\param[in] sfc_z0_type integer, flag for surface roughness option over ocean +!!\param[in] wet logical, flag nonzero wet surface fraction +!!\param[in] dry logical, flag nonzero land surface fraction +!!\param[in] ice logical, flag nonzero ice surface fraction +!!\param[in] tskin real, surface skin temperature (\f$K\f$) +!!\param[in] tsurf real, surface skin temperature after iter (\f$K\f$) +!!\param[in] snwdph real, surface snow thickness water equiv (\f$mm\f$) +!!\param[in] z0rl real, surface snow thickness (\f$cm\f$) +!!\param[in,out] ustar real, surface friction velocity (\f$m/s\f$) +!!\param[in,out] cm real, surface drag coeff for momentum in air +!!\param[in,out] ch real, surface drag coeff for heat and moisture in air +!!\param[in,out] rb real, bulk richardson number at lowest mo lev +!!\param[in,out] stress real, surface wind stress (\f$m2/s2\f$) +!!\param[in,out] fm real, Monin Obukhov simi func for momentum +!!\param[in,out] fh real, Monin Obukhov simi func for heat +!!\param[in,out] fm real, Monin Obukhov simi func for momentum 10m +!!\param[in,out] fh real, Monin Obukhov simi func for heat 2m +!!\param[out] wind real, wind speed at lowest mod lev (\f$m/s\f$) + + subroutine sfc_diff_hafs(im,ps,u1,v1,t1,q1,z1, &!intent(in) & prsl1,prslki,ddvel, &!intent(in) & sigmaf,vegtype,shdmax,ivegsrc, &!intent(in) @@ -27,9 +109,10 @@ subroutine sfc_diff_hafs(im,ps,u1,v1,t1,q1,z1, &!intent(in) & flag_iter,redrag, &!intent(in) & u10m,v10m,sfc_z0_type, &!wang,z0 type !intent(in) & wet,dry,icy, &!intent(in) - & tskin, tsurf, snwdph, z0rl, ustar, - & cm, ch, rb, stress, fm, fh, fm10, fh2, - & wind) &!intent(out) + & tskin, tsurf, snwdph, z0rl, ustar, & + & cm, ch, rb, stress, fm, fh, fm10, fh2, & + & wind, & + & errmsg,errflg) &!intent(out) ! use funcphys, only : fpvs use physcons, rvrdm1 => con_fvirt