diff --git a/physics/PBL/SATMEDMF/canopy_driver.F b/physics/PBL/SATMEDMF/canopy_driver.F new file mode 100644 index 000000000..82c8bf84c --- /dev/null +++ b/physics/PBL/SATMEDMF/canopy_driver.F @@ -0,0 +1,1576 @@ +!> \file canopy_driver.F + +!> This file contains ... + module canopy_driver + use mfpbltq_mod + use tridi_mod + use mfscuq_mod + use canopy_utils_mod + use satmedmfvdifq_can_mod + + use canopy_mask_mod !Feb13: , only : canopy_mask_init, canopy_mask_run + use canopy_levs_mod !Feb13: , only : canopy_levs_init, canopy_levs_run + use canopy_transfer_mod !Feb13: , only : canopy_transfer_init, +!Feb13: & canopy_transfer_run + + contains + +!> \section arg_table_canopy_driver_init Argument Table +!! \htmlinclude canopy_driver_init.html +!! + subroutine canopy_driver_init (satmedmf, + & isatmedmf,isatmedmf_vdifq, + & errmsg,errflg) + + logical, intent(in ) :: satmedmf + integer, intent(in) :: isatmedmf,isatmedmf_vdifq + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! Consistency checks + if (.not. satmedmf) then + write(errmsg,fmt='(*(a))') 'Logic error: satmedmf = .false.' + errflg = 1 + return + end if + + if (.not. isatmedmf==isatmedmf_vdifq) then + write(errmsg,fmt='(*(a))') 'Logic error: satmedmfvdif is ', + & 'called, but isatmedmf/=isatmedmf_vdifq.' + errflg = 1 + return + end if + + end subroutine canopy_driver_init + +!> \section arg_table_canopy_driver_run Argument Table +!! \htmlinclude canopy_driver_run.html +!! + subroutine canopy_driver_run(im,km,ntrac,ntcw,ntrw, + & ntiw,ntke,ntchm,ntchs,ntche, ntoz,nto3, + & ndtend, ! in + & con_rocp, + & grav,pi,rd,cp,rv,hvap,hfus,fv,eps,epsm1, +!The following three variables are for SA-3D-TKE + & def_1,def_2,def_3,sa3dtke,dku3d_h,dku3d_e, + & dv,du,tdt,rtg, ! inout: dv,du,tdt,rtg + & u1,v1,t1,q1,usfco,vsfco,use_oceanuv, ! in + & swh,hlw,xmu,garea,zvfun,sigmaf, ! in + & psk,rbsoil,zorl,u10m,v10m,t2m, q2m,fm,fh, + & tsea,heat,evap,stress,spd1, + & kpbl, ! inout: kpbl + & pgr, + & prsi,del,prsl,prslk,phii,phil,delt,tte_edmf, + & dspheat, ! in + & dusfc,dvsfc,dtsfc,dqsfc,hpbl, ! in: dusfc,dvsfc,dtsfc,dqsfc,hpbl + & dkt,dku,tkeh, ! inout: dkt,dku, tkeh + & dkt_can,dku_can, ! out + & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, ! in + & rlmx,elmx,sfc_rlm,tc_pbl,use_lpt, ! in + & do_canopy, cplaqm, claie, cfch, cfrt, cclu, cpopu, ! in + & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, ! inout: dtend (.ldiag3d.) + & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, + & errmsg,errflg) + +! + use machine , only : kind_phys + use funcphys , only : fpvs +! + implicit none +! +!---------------------------------------------------------------------- + integer, intent(in) :: im, km, + & ntrac, ntcw, ntrw, ntiw, ntke, ntqv, + & ntchm,ntchs,ntche, ntoz,nto3, ndtend + integer, intent(in) :: sfc_rlm + integer, intent(in) :: tc_pbl + integer, intent(in) :: use_lpt + integer, intent(in) :: kinver(:) + integer, intent(inout) :: kpbl(:) + logical, intent(in) :: gen_tend,ldiag3d +! + real(kind=kind_phys), intent(in) :: grav,pi,rd,cp,rv,hvap,hfus,fv, + & eps,epsm1, + & con_rocp + real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr + real(kind=kind_phys), intent(in) :: rlmx, elmx +!PCC CANOPY------------------------------------ + logical, intent(in) :: do_canopy, cplaqm + + real(kind=kind_phys), optional, intent(in) :: +! 2D + & claie(:) , cfch(:), + & cfrt(:) , cclu(:), cpopu(:) + + !---------------------------------------------- + real(kind=kind_phys), intent(inout) :: + & dv(:,:), du(:,:), + & tdt(:,:), tkeh(:,:), + & rtg(:,:,:) + real(kind=kind_phys), intent(in) :: + & u1(:,:), v1(:,:), + & usfco(:), vsfco(:), + & t1(:,:), q1(:,:,:), +!The following two variables are for SA-3D-TKE + & def_1(:,:), def_2(:,:), def_3(:,:), + & swh(:,:), hlw(:,:), + & xmu(:), garea(:), + & zvfun(:), sigmaf(:), + & psk(:), rbsoil(:), + & zorl(:), tsea(:), + & u10m(:), v10m(:), + & t2m(:), q2m(:), + & fm(:), fh(:), + & evap(:), heat(:), + & stress(:), spd1(:), + & pgr(:), + & prsi(:,:), del(:,:), + & prsl(:,:), prslk(:,:), + & phii(:,:), phil(:,:) + + real(kind=kind_phys), intent(inout), dimension(:,:,:), optional :: + & dtend + + integer, intent(in) :: dtidx(:,:), index_of_temperature, + & index_of_x_wind, index_of_y_wind, index_of_process_pbl + logical, intent(in) :: use_oceanuv + real(kind=kind_phys), intent(in) :: + & dusfc(:), dvsfc(:), + & dtsfc(:), dqsfc(:) + real(kind=kind_phys), intent(inout) :: + & hpbl(:) ! use resolved hpbl in non-canopy columns + real(kind=kind_phys), intent(inout) :: + & dkt(:,:), dku(:,:) + real(kind=kind_phys), intent(out) :: + & dkt_can(:,:), dku_can(:,:) + + logical, intent(in) :: sa3dtke !flag for SA-3D-TKE scheme +! +! +! flag for tke dissipative heating + logical, intent(in) :: dspheat +! flag for TTE-EDMF scheme + logical, intent(in) :: tte_edmf + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!For passing dku to the dyn_core (SA-3D-TKE scheme) + real(kind=kind_phys), intent(in) :: + & dku3d_h(:,:),dku3d_e(:,:) + +! +!---------------------------------------------------------------------- +!*** +!*** local variables + + integer i,is,k,n,ndt,km1,kmpbl,kmscu,ntrac1, + & idtend + + real(kind=kind_phys) dtdz1(im), gdx(im), + & phih(im), phim(im), + & phims(im), prn(im,km-1), + & rbdn(im), rbup(im), thermal(im), + & ustar(im), wstar(im), + & ust3(im), wst3(im), + & z0(im), crb(im), tkemean(im), + & hgamt(im), hgamq(im), + & wscale(im),vpert(im), + & zol(im), sflux(im), + & sumx(im), tx1(im), tx2(im) +! + real(kind=kind_phys) zi(im,km+1), zl(im,km), zm(im,km), + & xkzo(im,km-1),xkzmo(im,km-1), + & xkzm_hx(im), xkzm_mx(im), tkmnz(im,km-1), + & rdzt(im,km-1),rlmnz(im,km), + & al(im,km-1), ad(im,km), au(im,km-1), + & f1(im,km), f2(im,km*(ntrac-1)) +! + real(kind=kind_phys) elm(im,km), ele(im,km), + & ckz(im,km), chz(im,km), + & diss(im,km-1),prod(im,km-1), + & bf(im,km-1), shr2(im,km-1), + & xlamue(im,km-1), xlamde(im,km-1), + & gotvx(im,km), rlam(im,km-1) +! + real(kind=kind_phys) aphi16, aphi5, + & wfac, cfac, + & gamcrt, gamcrq, sfcfrac, +! & conq, cont, conw, + & dsdz2, dsdzt, dkmax, + & dsig, dt2, dtodsd, + & dtodsu, g, factor, dz, + & gocp, gravi, zol1, zolcru, + & concmin, + & buop, shrp, dtn, + & prnum, prmax, prmin, prtke, + & prscu, pr0, ri, + & dw2, dw2min, zk, + & elmfac, elefac, dspmax, + & alp, clwt, cql, + & f0, robn, crbmin, crbmax, + & es, qs, value, onemrh, + & cfh, gamma, elocp, el2orc, + & epsi, beta, chx, cqx, + & rdt, rdz, qmin, qlmin, + & rimin, rbcr, rbint, tdzmin, + & rlmn, rlmn0, rlmn1, rlmn2, + & ttend, utend, vtend, qtend, + & zfac, zfmin, vk, spdk2, + & tkmin, tkbmx, xkgdx, + & xkinv1, xkinv2, + & zlup, zldn, cs0, csmf, + & tem, tem1, tem2, tem3, + & ptem, ptem0, ptem1, ptem2 +! + real(kind=kind_phys) slfac +! + real(kind=kind_phys) vegflo, vegfup, z0lo, z0up, vc0, zc0 +! + real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck +! + real(kind=kind_phys) qlcr, zstblmax, hcrinv +! + real(kind=kind_phys) h1 + + real(kind=kind_phys) bfac, mffac + + real(kind=kind_phys) q1_new(im,km,ntrac-1) + + integer kount + +!PCC_CANOPY------------------------------------ + integer COUNTCAN,KCAN + ! Declare local maximum canopy layers + integer, parameter :: MAXCAN = 1000 + + real(kind=kind_phys) :: FCH, + & ZI05, ZFL, DZFL, BOTCAN, FZI05, TTCORR, + & UUCAN, VVCAN, TTCAN, TKECAN, TKEHCAN, + & UU1, VV1, TT1, TKE1, TKEH1, + & UU_INT,VV_INT,TT_INT,TKE_INT, TKEH_INT, + & TT_SUM, ZZ_INT + + real(kind=kind_phys) :: ZCANX (MAXCAN), ZOOOX(MAXCAN), + & UUX(MAXCAN), VVX(MAXCAN), TTX(MAXCAN), + & TKEX(MAXCAN), TKEHX(MAXCAN) +!PCC_CANOPY------------------------------------ + + real(kind=kind_phys) :: + & dv_can(im,km), du_can(im,km), + & duv_can(im,km), + & tdt_can(im,km), rtg_can(im,km,ntrac) + + real(kind=kind_phys) :: + & dum3d_h (im, km) , dum3d_e(im, km), + & tkeh_mod (im, km) + + real(kind=kind_phys) :: dtend_can(im, km , ndtend) + +! Out: list sat_canopy call + real(kind=kind_phys) :: dusfc_can(im), dvsfc_can(im), + & dtsfc_can(im), dqsfc_can(im), + & hpbl_can(im) + + integer :: kpbl_can(im) + + real(kind=kind_phys) :: + & rho1(im,km), + & t2 (im,km), + & u2 (im,km), v2(im,km), ws2(im,km), + & rho2(im,km), duv(im,km) + +! Number of canopy layers + integer, parameter :: nkc = 3 + integer :: nkt ! # of resolved model layers plus canopy layers + + integer + & kcan1, kc_can, + & kc, nkt1 , + & kmod (im, km) , + & kcan3 (im, nkc) , + & nfrct (km+nkc, im) , !nkt + & ifrct (km+nkc, 2, im) !nkt + + real(kind=kind_phys) :: +! 2D arrays + & FRT_MASK (im) , +! met2d arrays + & u2_mod (im, km) , v2_mod(im, km), + & ws2_mod (im, km) , t2_mod(im, km), + & du_mod (im, km) , dv_mod(im, km), + & duv_mod (im, km) , tdt_mod(im, km), + & U10M_CAN (im) , + & V10M_CAN (im) , +! all gas-phase species array +! NB. mfpbltq_mod: q1(ix,km,ntrac1) with ntrac1 = ntrac - 1 + & RTG1_MOD(im, km, ntrac), ! before diffusion + & Q1_MOD (im, km, ntrac), ! before diffusion + & Q2_MOD (im, km, ntrac), ! after diffusion + & Q2 (im, km, ntrac), ! after diffusion + & RTG_MOD (im, km, ntrac), ! after diffusion +! sat_can inputs + & Q1_CAN (im, km , ntrac), ! size (km) before diffusion + & Q2_CAN (im, km , ntrac), ! size (km) after diffusion + & U1_CAN (im, km ) , ! size (km) + & V1_CAN (im, km ) , ! size (km) + & WS1_CAN (im, km ) , ! size (km) + & T1_CAN (im, km ) , ! size (km) + & TKEH_CAN (im, km ) , +! + & swh_can (im, km) , + & hlw_can (im, km) , +! sat_can inputs + & phii_can (im, km+1) , + & prsi_can (im, km+1) , + & prsl_can (im, km) , + & del_can (im, km) , + & prslk_can (im, km) , + & phil_can (im, km) , +! Canopy layers + & DKT_CAN3 (im, km+nkc) , + & DKU_CAN3 (im, km+nkc) , + & QV_CAN3 (im, km+nkc) , ! nkt before diffusion + & Q1_CAN3 (im, km+nkc, ntrac), ! nkt before diffusion + & Q2_CAN3 (im, km+nkc, ntrac), ! nkt after diffsion +! before diffusion + & WS1_CAN3 (im, km+nkc) , ! using km for now only + & U1_CAN3 (im, km+nkc) , ! using km for now only + & V1_CAN3 (im, km+nkc) , ! using km for now only + & T1_CAN3 (im, km+nkc) , ! using km for now only + & RHO1_CAN3 (im, km+nkc) , + & TKEH_CAN3 (im, km+nkc) , +! after diffusion + & WS2_CAN3 (im, km+nkc) , + & U2_CAN3 (im, km+nkc) , + & V2_CAN3 (im, km+nkc) , + & T2_CAN3 (im, km+nkc) , + & RHO2_CAN3 (im, km+nkc) , +! 2D + & Q1_2M (im, ntrac), ! before diffusion + & Q2_2M (im, ntrac), ! after diffusion +! met3d arrays + & phii_can3 (im, km+nkc+1) , !nkt + & phil_can3 (im, km+nkc) , + & prsi_can3 (im, km+nkc+1) , + & prsl_can3 (im, km+nkc) , + & prslk_can3 (im, km+nkc) , + & del_can3 (im, km+nkc) , +! + & zi_can3 (im, km+nkc+1) , !nkt + & ZL_CAN3 (im, km+nkc) , ! zl_can is ZH_CAN + & ZM_CAN3 (im, km+nkc) , ! zm_can is ZF_CAN + & dz_can3 (im, km+nkc) , +! +! model layers + & wind_dir_to_rad(im, km) , + & ws1 (im, km) , + & wdir (im, km) , + +! layer height arrays !layers are in reverse order! +! 1 is top resolved layer +! km is bottom model hybrid layer +! km+nkc=nkt is bottom canopy layer + & zmom_can3 (im, km+nkc) , ! dim(im, nkt+1) + & zmid_can3 (im, km+nkc) , + & sigmom_can3 (im, km+nkc+1) , ! ~zm (nkt) or ~zi (nkt+1) + & sigmid_can3 (im, km+nkc) , ! ~zl + & massair_can3 (im, km+nkc) , + & massair (im, km) , + & mmr_o3_can3 (im, km+nkc) , + & frctr2c (km+nkc, 2, im) , + & frctc2r (km+nkc, 2, im) + +!! + parameter(bfac=100.) + parameter(wfac=7.0,cfac=4.5) + parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) + parameter(vk=0.4,rimin=-100.,slfac=0.1) + parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) + parameter(rlmn=30.,rlmn0=5.,rlmn1=5.,rlmn2=10.) + parameter(prmin=0.25,prmax=4.0) + parameter(pr0=1.0,prtke=1.0,prscu=0.67) + parameter(f0=1.e-4,crbmin=0.15,crbmax=0.35) + parameter(tkmin=1.e-9,tkbmx=0.2,dspmax=10.0) + parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) + parameter(concmin = 1.0E-30) ! Minimum conc "rbdriver" + parameter(aphi5=5.,aphi16=16.) + parameter(elmfac=1.0,elefac=1.0,cql=100.) + parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=1000.) + parameter(qlcr=3.5e-5,zstblmax=2500.) + parameter(xkinv1=0.15,xkinv2=0.3) + parameter(h1=0.33333333,hcrinv=250.) + parameter(vegflo=0.1,vegfup=1.0,z0lo=0.1,z0up=1.0) + parameter(vc0=1.0,zc0=1.0) + parameter(ck1=0.15,ch1=0.15) + parameter(cs0=0.4,csmf=0.5) + parameter(rchck=1.5,ndt=20) + real(kind=kind_phys), parameter :: epsilon = 1.e-10 + +! Consistency checks + if (.not. (do_canopy .and. cplaqm ) ) then + write(errmsg,fmt='(*(a))') 'Logic error: do_canopy = .false.' + return + end if + +! Number of combined canopy plus resolved model layers + nkt = km + nkc ! # of resolved model layers plus canopy layers + nkt1 = nkt - 1 + + if (tc_pbl == 0) then + ck0 = 0.4 + ch0 = 0.4 + ce0 = 0.4 + else if (tc_pbl == 1) then + ck0 = 0.55 + ch0 = 0.55 + ce0 = 0.12 + endif + gravi = 1.0 / grav + g = grav + gocp = g / cp +! 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) !kpa + elocp = hvap / cp + el2orc = hvap * hvap / (rv * cp) + +! +!************************************************************************ +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!> ## Compute preliminary variables from input arguments + dt2 = delt + rdt = 1. / dt2 +! +! the code is written assuming ntke=ntrac +! if ntrac > ntke, the code needs to be modified +! + ntrac1 = ntrac - 1 + km1 = km - 1 + kmpbl = km / 2 + kmscu = km / 2 +!> - Compute physical height of the layer centers and interfaces from +!! the geopotential height (\p zi and \p zl) + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + ckz(i,k) = ck1 + chz(i,k) = ch1 + rlmnz(i,k) = rlmn0 + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo + do k=1,km + do i=1,im + zm(i,k) = zi(i,k+1) + enddo + enddo +!> - Compute horizontal grid size (\p gdx) + do i=1,im + gdx(i) = sqrt(garea(i)) + enddo + +!> - Some output variables and logical flags are initialized +! do i = 1,im +! z0(i) = 0.01 * zorl(i) +! rho_a(i) = prsl(i,1)/(rd*t1(i,1)*(1.+fv*max(q1(i,1,1),qmin))) + +! pblflg(i)= .true. +! sfcflg(i)= .true. +! if(rbsoil(i) > 0.) sfcflg(i) = .false. +! pcnvflg(i)= .false. +! scuflg(i)= .true. +! if(scuflg(i)) then +! radmin(i)= 0. +! mrad(i) = km1 +! krad(i) = 1 +! lcld(i) = km1 +! kcld(i) = km1 +! endif +! enddo + +! Initialize canopy layers concentrations with values before diffusion + if (do_canopy .and. cplaqm) then + + do k = 1,km + do i = 1,im + rho1(i,k) = prsl(i,k)/ + & (rd*t1(i,k)* + & (1.+fv*max(q1(i,k, 1),qmin))) + + enddo + enddo + + CALL canopy_mask_init( im, km, nkc, nkt, + & claie, cfch, cfrt, cclu, cpopu, ! in: + & FRT_MASK, ! out + & errmsg, errflg) + + if (errflg /= 0) return + + CALL canopy_levs_init( im, km, nkc, nkt, + & ntrac, ntqv, ntke, ! ndtend, ! in + & zi, zl, zm, ! in 3D + & prsl, prsi, ! in 3D + & dv, du, tdt, rtg, ! in 3D + & u1, v1, t1, q1, ! in 3D / 4D + & rho1, dkt, dku, ! in 3D +! & dtend, + & zmom_can3, zmid_can3, !out 3D + & sigmom_can3, sigmid_can3, !out 3D + & ZL_CAN3, ZM_CAN3, !out 3D ZL=half- and ZM=full-layer height + & PRSL_CAN3, PRSI_CAN3, !out 3D set to zero + & dv_can, du_can, tdt_can, rtg_can, !out 3D size (km) + & T1_CAN3, QV_CAN3,rho1_CAN3, !out 3D set to zero + & WS1_CAN3, DKT_CAN3, DKU_CAN3, !out 3D set to WS DKT + & Q1_CAN3, Q1_2M, !out 4D set to Q1 +! & DTEND_CAN, + & errmsg, errflg) + +! Zero in-canopy tendencies + dtend_can(:, :, : ) = 0.0 + + if (errflg /= 0) return + +! ================ +! In; Q1 (:,km ,NTRAC) +! Out: Q1_CAN3(:,1:3,NTRAC) <= Q1(:,1,NTRAC) ! ALL CANOPY & NON-CANOPY COLUMNS ! +! =============== + + CALL canopy_transfer_init(im, km, nkc, nkt, !in + & massair_can3, massair, !out + & mmr_o3_can3, !inout + & nfrct, ifrct, !out + & frctr2c, frctc2r, !out + & errmsg, errflg ) + + if (errflg /= 0) return + + + endif ! (do_canopy .and. cplaqm) + + + !PCC_CANOPY------------------------------------ + kount=0 + if (do_canopy .and. cplaqm) then + +! NB. Call canopy routines after eddy diffusivities are calculated!!! + + CALL canopy_mask_run( im, km, nkc, nkt, !in + & claie, cfch, cfrt, cclu, cpopu, !in + & FRT_MASK, !out + & errmsg, errflg) + +! if (errflg /= 0) return + +! Wind direction, degrees +! ATAN2(Y, X) computes the principal value of the argument function of the complex number X + i Y. +! This function can be used to transform from Cartesian into polar coordinates and allows to determine the angle in the correct quadrant. + + do k=1,km + do i=1,im + + ws1(i,k) = sqrt(u1(i,k)**2+v1(i,k)**2) + + wind_dir_to_rad(i,k) = + & atan2(u1(i,k),v1(i,k)) ! to radians +! & atan2(u1(i,k)/ws1(i,k),v1(i,k)/ws1(i,k)) ! to radians + enddo + enddo + +! =============== +! In canopy_levs_run, the vertical layers are going down (reversed to phot) +! +! k = 1, NLAYT from top to bottom of augmented canopy+resolved model layers +! 1 = top model layer +! NLAYS = bottom resolved model layer +! NLAYC = 3 canopy layers +! NLAYT = NLAYS + NLAYC, augmented canopy plus resolved model layers +! NLAYS+1= top canopy layer at 1.0*CH +! NLAYS+2= middle canopy layer at 0.5*CH +! NLAYS+3= bottom canopy layer at 0.2*CH +! ================= + + CALL canopy_levs_run(im, km, nkc, nkt, ! in + & ntrac, ntqv, ntke, ! in + & RD, PI, ! in gry gas constant + & zi, zl, zm, ! in + & prsl, prsi, pgr, ! in (Pa) + & cfch, ! in: canopy data input + & garea, u10m,v10m, fm, fh, ! in: 2D + & rbsoil, ! in: 2D + & t2m, q2m, ! in 2D + & stress, spd1, ! in: 2D + & dv, du, tdt, rtg, ! in: 3D + & u1, v1, t1, q1, ! in: 3D " 4D + & rho1, dkt, dku, ! in 3D + & FRT_MASK, ! in 2D canopy_mask + & kmod, kcan3, ! out + & zmom_can3, zmid_can3, ! out + & sigmom_can3, sigmid_can3, ! out + & ZL_CAN3, ZM_CAN3, ! out: zl_can=half- and zm_can=full-layer height + & PRSL_CAN3, PRSI_CAN3, ! out: mean layer pressure; air pressure at model layer interfaces + & dv_can, du_can, tdt_can, rtg_can, ! out: 3D size (km) + & T1_CAN3, QV_CAN3, rho1_CAN3, ! out 3D: 2-m interpolated T1 QV rho1 + & WS1_CAN3, DKT_CAN3, DKU_CAN3, ! out 3D: 10-m interpolated WS1 + & Q1_CAN3, Q1_2M, ! inout kg kg-1 + & errmsg, errflg) ! out + + if (errflg /= 0) return + +! ================ +! Out: +! T1_CAN3 (:,:,NLAYT) +! QV_CAN3 (:,:,NLAYT) Q2m interpolated +! PRSI_CAN3 ( NLAYT+1) +! PRSL_CAN3 (:, NLAYT) +! rho1_CAN3 (:, NLAYT) +! Q1_CAN3(1,2,3) <= Q1(1) ! ALL CANOPY & NON-CANOPY COLUMNS ! + +! !Layers in reverse order! +! 1 is top resolved layer +! km is bottom model hybrid layer +! nkt is bottom canopy layer +! zmid_can3 (:,:, NLAYT) layers are in reverse order! +! zmom_can3 (:,:, NLAYT+1) layers are in reverse order! +! massair_can3(:,:, NLAYT) : mass of air in canopy layers (kg) +! massair (:,:, NLAYS) : mass of air in model layers (kg) +! (gathered canopy + resolved scale columns) +! nfrct (NLAYT, :,:) : Number of original model levels contributing to canopy level k +! ifrct (NLAYT,2,:,:) : Index of the original model level contributing to canopy level k +! frctr2c(NLAYT,2,:,:) : Fractional contribution of the original model level to canopy level k +! frctc2r(NLAYT,2,:,:) : Fractional contribution of the canopy level to the original model level +! ================ + + do i = 1,im +! rho1_can_sfc(i) = prsl_can3(i,1)/ +! & (rd*t1_can3(i,1)*(1.+fv*max(q1_can3(i,1, ntqv),qmin))) ! ntqv=1 + enddo + + do k = 1,km ! ntk to do + do i = 1,im + + q1_can3(i,k, ntqv) = qv_can3(i,k) ! 2-m interpolated humidity + + rho1_can3(i,k) = prsl_can3(i,k)/ + & (rd*t1_can3(i,k)* + & (1.+fv*max(q1_can3(i,k, ntqv),qmin))) ! ntqv=1 2-m interpolated + + enddo + enddo + +! Humidity on canopy layers, interpolated from q2m qv_can3 +! Humidity overwritten in "resolved_to_canopy" mass transfer +! q1_can3(:,1:km, ntqv ) = qv_can3(:,1:km) + +! Above canopy layers + do k=1,km + do i=1,im + ! kc = 4,5,6.. 67 + kc = nkc + k + del_can3 (i,kc) = prsi_can3(i,kc) - prsi_can3(i,kc+1) + +! Exner function canopy layers +! !< exner function = (p/p0)**rocp + prslk_can3(i,kc) = (prsl_can3(i,kc) /pgr(i)) ** con_rocp + + enddo + enddo + +! Canopy layers: kc = 1, 2, 3 + do kc = 1, nkc + do i = 1,im + +! Canopy columns + IF (FRT_MASK(i) > 0.) THEN + del_can3(i,kc) = prsi_can3(i, kc) - prsi_can3(i, kc+1) + +! Non-canopy columns set to del(1) + ELSE IF (FRT_MASK(i) <= 0.) THEN + del_can3(i,kc) = del(i,1) + + ENDIF + +! Exner function canopy layers +! !< exner function = (p/p0)**rocp + prslk_can3(i,kc) = (prsl_can3(i,kc) /pgr(i)) ** con_rocp + + end do + end do + +!-------- +! zmid(1) = zl(km) is top height model layer centers +! zmid(km) = zl(1) is bottom height model layer centers +! NB. +! ZH_CAN (i, nkt + 1 - k) = zmid_can(i, k) (k = 1, nkt) combined layer centers => rename zl_can +! zi height model layer interfaces +! dz_can = zl_can3(i,k+1) - zl_can3(i,k) +! so zm(i,k) = zi(i,k+1) = zl_can3(i,k) + dz_can3(i,k)/2 +! zm (:,k) = zi(:,k+1), so zm_can (i, k) = zi_can3(i,k+1) (k=1,km) + +! In-Canopy layers: kc = 1, 2, 3 + zi_can3(:, 1) = 0. + do kc = 1, nkc + do i = 1,im + ! kc+1 = 2, 3, 4 + zi_can3(i,kc+1) = zm_can3(i, kc) + dz_can3(i,kc) = zi_can3(i, kc+1) - zi_can3(i, kc) + end do + end do + +! Above canopy layers + do k = 1,km + do i = 1,im + ! kc = 4,5,6.. 67 + kc = nkc + k + + ! kc+1 = 5,6,7 ...68 + zi_can3(i,kc+1) = zm_can3(i, kc) ! upper interface + +! print*,'canopy_driver: zm_can3= ',i, kc, ! 5 +! & zm_can3(i, kc), +! & zi_can3(i, kc) + + dz_can3(i,kc) = zi_can3(i, kc+1) - zi_can3(i, kc) + end do + end do + + + +!> - Compute geopotential physical height of the layer centers and interfaces from +!! the physical height (\p zi and \p zl) + do k=1,nkt + do i=1,im + phil_can3(i,k) = zl_can3(i,k) * grav + phii_can3(i,k) = zi_can3(i,k) * grav + enddo + enddo + do i=1,im + phii_can3(i,nkt+1) = zi_can3(i,nkt+1) * grav + enddo + + do k = 1,km + + ! nkt is top + ! nkc+1 is bottom + kc=nkc+k + + do i=1,im + + u1_can3(i,kc) = ws1_can3(i,kc) * sin(wind_dir_to_rad(i,k)) ! m/s + v1_can3(i,kc) = ws1_can3(i,kc) * cos(wind_dir_to_rad(i,k)) ! m/s + + end do + end do + +! Canopy Layers: use 1hy resolved model layer wind direction + do kc = 1,nkc + do i=1,im + + u1_can3(i,kc) = ws1_can3(i,kc) * sin(wind_dir_to_rad(i,1)) ! m/s + v1_can3(i,kc) = ws1_can3(i,kc) * cos(wind_dir_to_rad(i,1)) ! m/s + + end do + end do + +! All columns & all layers + q1_mod (:,1:km, :) = q1 (:,1:km, :) ! before "resolved_to_canopy" +! Q1_2M ... move out of "canopy_levs" + +!=============================================================================== +! Distribute tracer concentration from model resolved layers into canopy layers +! flag = 0 "resolved_to_canopy" +!=============================================================================== + + CALL canopy_transfer_run(im, km, nkc, nkt, !in + & ntrac, ntoz, !in + & garea, !in + & zi, zl, zm, !in + & q1, rho1, !in kg kg-1 + & 0, !in 0 = "resolved_to_canopy" + & FRT_MASK, !in + & kmod, kcan3, !in + & zmom_can3, zmid_can3, !in + & PRSL_CAN3, rho1_CAN3, !in: before diffusion + & Q1_MOD, Q1_CAN3, Q1_2M, !inout: kg kg-1 before diffusion + & massair_can3, massair, !inout + & mmr_o3_can3, !inout + & nfrct, ifrct, !inout + & frctr2c, frctc2r, !inout + & errmsg, errflg ) + + if (errflg /= 0) return + +! ============== +! Input: +! Q1 (:,:, NLAYS, ntrac) : Chemical tracers conc. ppmv on model levels +! +! Output: +! Q1_CAN3(:,:, NLAYT, ntrac) : Chemical tracers conc. ppmv on combined canopy+resolved layers +! ! CANOPY COLUMNS ONLY ! +! Q1_2M (:,: , ntrac) : 2M Chemical tracers conc. ppmv Diagnostics +! +! ================================ + +! Comment out to use 2-m interpolated value from "canopy_levs" qv_can3(:,:) +! q1_can3 (:,1:km, ntqv) = qv_can3(:,1:km) ! ntqv=1 + +! Subset the canopy tracers/arrays for input to "sat_can", since routine is coded on dim(km) + prsi_can (:,1:km+1) = prsi_can3 (:,1:km+1) + prsl_can (:,1:km) = prsl_can3 (:,1:km) + prslk_can (:,1:km) = prslk_can3 (:,1:km) + + do i = 1,im + IF (FRT_MASK(i) > 0.) THEN + del_can (i,1:km) = del_can3(i,1:km) + phii_can (i,1:km+1) = phii_can3(i,1:km+1) + phil_can (i,1:km) = phil_can3(i,1:km) +! Set Non-Canopy columns to resolved layer thickness + ELSE IF (FRT_MASK(i) <= 0.) THEN + del_can (i,1:km) = del (i,1:km) + phii_can (i,1:km+1) = phii(i,1:km+1) + phil_can (i,1:km) = phil(i,1:km) + ENDIF + enddo + +! NB. Using 10-m interpolated values creates shear and gives very high TKE tendencies + + t1_can (:,1:km) = t1_can3 (:,1:km) + + dku_can (:,1:km) = dku_can3 (:,1:km) ! "canopy_levs" + dkt_can (:,1:km) = dkt_can3 (:,1:km) ! "canopy_levs" + +! Prepare arrays for "Resolved_to_Canopy" transfer +! Mass tracers (ntrac1) except TKE + q1_can (:,1:km, 1:ntrac1) = q1_can3(:,1:km, 1:ntrac1) ! ntrac1 "resolved_to_canopy" +! TKE tracer + q1_can (:,1:km, ntke ) = q1_can3 (:,1:km, ntke ) ! ntke "resolved_to_canopy" + + endif !do_canopy .and. cplaqm + + if (do_canopy .and. cplaqm) then + +! 3D array on combined canopy plus resolved model layers + +! Test with km combined canopy plus resolved layers, so skip the top combined 3 layers +! This should be nkt layers... dv_can(:,nkc+1:nkt) = dv(:,1:km) ! nkt combined canopy plus resolved layers + +! Sub-Canopy + swh_can (:, nkc+1:km ) = swh(:,1:km-nkc) + swh_can (:, 3 ) = swh(:,1 ) + swh_can (:, 2 ) = swh(:,1 ) + swh_can (:, 1 ) = swh(:,1 ) + + hlw_can (:, nkc+1:km ) = hlw(:,1:km-nkc) + hlw_can (:, 3 ) = hlw(:,1 ) + hlw_can (:, 2 ) = hlw(:,1 ) + hlw_can (:, 1 ) = hlw(:,1 ) + +! Subset combined layers (minus top nkc layers) + do k = km-nkc, 1, -1 ! top to 1hy model layer + ! km is top combined subset + ! nkc+1 is bot combined + kc= nkc+k ! 4th from top (nkt) to nkc+1 combined canopy plus resolved model layer + +! Above-canopy TKE tracer set to hybrid model layers ("resolved_to_canopy" only does mass tranfer of mass tracers) + q1_can (:,kc, ntke ) = q1(:,k, ntke ) ! ntke always on + +! Above-canopy wind components set to hybrid model layers + u1_can (:,kc) = u1 (:,k) + v1_can (:,kc) = v1 (:,k) + + ws1_can(:,kc) = sqrt(u1_can(:,kc)**2+v1_can(:,kc)**2) + + end do + + do kc = 1, nkc ! 3-nkc canopy layers + +! Sub-canopy values of TKE set to 1hy model layer +! ("canopy_transfer" only does mass transfer to mass conc. tracers) + q1_can (:,kc, ntke ) = q1(:,1, ntke ) ! ntke always on + +!Sub-canopy values of wind components set to 1hy model layer + u1_can (:,kc) = u1 (:,1) + v1_can (:,kc) = v1 (:,1) + + ws1_can(:,kc) = sqrt(u1_can(:,kc)**2+v1_can(:,kc)**2) + end do + +! +!> - Call satmedmfvdifq_can(), which is ... +!! to take into account ... + CALL satmedmfvdifq_can(im,km,ntrac,ntcw,ntrw, + & ntiw,ntke,grav,pi,rd,cp,rv,hvap,hfus,fv,eps,epsm1, +!The following three variables are for SA-3D-TKE + & def_1,def_2,def_3,sa3dtke,dum3d_h,dum3d_e, + & dv_can,du_can,tdt_can,rtg_can, ! InOut + & u1_can,v1_can,t1_can, q1_can, ! In: canopy inputs + & usfco,vsfco,use_oceanuv, + & swh_can,hlw_can, ! In: canopy inputs + & xmu,garea,zvfun,sigmaf, + & psk,rbsoil,zorl,u10m,v10m,fm,fh, + & tsea,heat,evap,stress,spd1, + & kpbl_can, ! Out + & prsi_can,del_can,prsl_can,prslk_can,phii_can,phil_can, ! In: canopy inputs + & delt,tte_edmf, + & dspheat, + & dusfc_can,dvsfc_can,dtsfc_can,dqsfc_can,hpbl_can, ! Out + & dkt, dku, tkeh_can, ! Out/Out:tkeh_can + & dkt_can,dku_can, ! In: canopy inputs + & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, + & rlmx,elmx,sfc_rlm,tc_pbl,use_lpt, + & do_canopy, cplaqm, + & ntqv, dtend_can, dtidx,index_of_temperature,index_of_x_wind, !inout: dtend (.ldiag3d.) + & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, + & errmsg,errflg) + +! Set non-canopy columns to resolved values +! NB. Only vars not ALREADY defined in non-canopy columns + do i = 1,im + IF (FRT_MASK(i) <= 0.) THEN + +! Non-canopy columns +! kpbl_can(i) = kpbl(i) ! kpbl zero before original sat call + hpbl_can(i) = hpbl(i) + +! Non-canopy columns + dusfc_can(i) = dusfc(i) ! dusfc is zero before the main sat call + dvsfc_can(i) = dvsfc(i) ! dvsfc is zero before the main sat call + dtsfc_can(i) = dtsfc(i) ! dtsfc is zero before the main sat call + dqsfc_can(i) = dqsfc(i) ! dqsfc is zero before the main sat call + + END IF !(FRT_MASK) + end do + +c +!> - Apply the tendencies of heat and moisture on canopy layers +! NB. before doing "canopy_to_resolved" mass transfer +c + +!U-wind/V-wind on original model layers after diffusion + u2 (:,1:km) = u1 (:,1:km) + + & du (:,1:km) * dt2 ! before "canopy_to_resolved" + v2 (:,1:km) = v1 (:,1:km) + + & dv (:,1:km) * dt2 ! before "canopy_to_resolved" + + ws2 (:,1:km) = sqrt(u2(:,1:km)**2+v2(:,1:km)**2) + duv (:,1:km) = (ws2(:,1:km) - ws1(:,1:km) )*rdt ! before "canopy_to_resolved" + +! Air temperature on original model layers after diffusion + t2 (:,1:km) = t1 (:,1:km) + + & tdt (:,1:km) * dt2 ! before "canopy_to_resolved" + +! All mass tracers (excepr TKE) on original model layers after diffusion for use in "canopy_to_resolved" + q2 (:,1:km, 1:ntrac1) = q1 (:,1:km, 1:ntrac1) + + & rtg (:,1:km, 1:ntrac1) * dt2 ! before "canopy_to_resolved" + +! TKE tracers on original model layers after diffusion for use in "canopy_to_resolved" + q2 (:,1:km, ntke ) = q1 (:,1:km, ntke ) + + & rtg (:,1:km, ntke ) * dt2 ! before "canopy_to_resolved" + q2 (:,:, ntke) = max(q2 (:,:, ntke), tkmin) ! before "canopy_to_resolved" + +! Temperature & wind components + t2_mod (:,1:km) = t2 (:,1:km) + u2_mod (:,1:km) = u2 (:,1:km) + v2_mod (:,1:km) = v2 (:,1:km) + +! Wind speed + ws2_mod (:,1:km) = sqrt(u2_mod(:,1:km)**2+v2_mod(:,1:km)**2) ! after diffusion + +! Tracers + q2_mod (:,1:km,:) = q2 (:,1:km, :) ! before "canopy_to_resolved" + tkeh_mod(:,1:km) = tkeh(:,1:km) ! before "canopy_to_resolved" + +! Tendencies + rtg_mod(:,1:km, :) = rtg(:,1:km, :) ! before "canopy_to_resolved" (km) + + tdt_mod(:,1:km) = tdt(:,1:km) ! before "canopy_to_resolved" (km) + + du_mod (:,1:km) = du (:,1:km) ! before "canopy_to_resolved" (km) + dv_mod (:,1:km) = dv (:,1:km) ! before "canopy_to_resolved" (km) + duv_mod(:,1:km) = duv(:,1:km) ! before "canopy_to_resolved" (km) + +! Air Density after diffusion model layers + rho2 (:,1:km) = prsl (:,1:km)/ + & (rd*t2 (:,1:km)* + & (1.+fv*max(q2 (:,1:km, ntqv),qmin))) ! ntqv=1 before "canopy_to_resolved" + +! Set non-canopy columns to resolved values +! NB. Only vars not ALREADY defined in non-canopy columns + +! Above-canopy layers (canopy layers below) non-canopy columns + do k = 1, km-nkc + ! km is top combined subset + ! nkc+1 is bot combined + kc= nkc+k ! 4th from top (nkt) to nkc+1 combined canopy plus resolved model layer + + do i = 1,im + IF (FRT_MASK(i) <= 0.) THEN + +! Above-canopy U-Wind/V-Wind/Temp non-canopy columns + u2_can3 (i,kc) = u2 (i,k) + v2_can3 (i,kc) = v2 (i,k) + t2_can3 (i,kc) = t2 (i,k) + +! Above-canopy TKE tracer half layers non-canopy columns + TKEH_CAN(i,kc) = TKEH(i,k) ! J s-1 after diffusion (km) + +! Tendencies + TDT_CAN (i,kc) = TDT (i,k) ! K s-1 after diffusion (km) + DU_CAN (i,kc) = DU (i,k) ! m s-2 after diffusion (km) + DV_CAN (i,kc) = DV (i,k) ! m s-2 after diffusion (km) + DUV_CAN (i,kc) = DUV (i,k) ! m s-2 after diffusion (km) + +! All tendencies except TKE non-canopy columns + RTG_CAN (i,kc, 1:ntrac1) = RTG (i,k, 1:ntrac1) ! kg kg-1 s-1 +! TKE Tendency non-canopy columns + RTG_CAN (i,kc, ntke) = RTG (i,k, ntke ) ! s-1 + + END IF ! (FRT_MASK) + end do ! i=1,im + end do ! k = 1, km-nkc + +! Canopy layers non-canopy columns + do kc = 1, nkc ! 3-nkc canopy layers + do i = 1,im + IF (FRT_MASK(i) <= 0.) THEN + +! Canopy layers U-wind/V-wind/Temp non-canopy columns + u2_can3 (i,kc) = u2 (i,1) + v2_can3 (i,kc) = v2 (i,1) + t2_can3 (i,kc) = t2 (i,1) + +! Canopy layers TKE half layers non-canopy columns + TKEH_CAN(i,kc) = TKEH(i,1) ! J S-1 (km) + +! Canopy layers Tendencies momentum and heat non-canopy columns + TDT_CAN (i,kc) = TDT (i,1) ! K s-1 (km) + DU_CAN (i,kc) = DU (i,1) ! m s-2 (km) + DV_CAN (i,kc) = DV (i,1) ! m s-2 (km) + DUV_CAN (i,kc) = DUV (i,1) ! m s-2 (km) + +! Canopy layers Tendencies mass tracers non-canopy columns + RTG_CAN (i,kc, 1:ntrac1) = RTG (i,1, 1:ntrac1) ! kg kg-1 s-1 (km) +! Canopy layers Tendency TKE tracer non-canopy columns + RTG_CAN (i,kc, ntke ) = RTG (i,1, ntke) ! J s-1 s-1 (km) + + ENDIF ! (FRT_MASK) + end do ! do i=1,im + end do ! kc=1,nkc + +! Combined layers (1,km) Humidity after diffusion +! Apply minimum value on humidity qmin before "canopy_to_resolved" + q2_can (:,:, ntqv) = q1_can (:,:, ntqv) + + & rtg_can (:,:, ntqv) * dt2 ! after diffusion (km) + q2_can (:,:, ntqv) = max(q2_can (:,:, ntqv),qmin) ! after diffusion (km) + +! Winds & temperature on combined layers after diffusion + +! Top 3 combined layers NOT calculated in "sat_can": fill with top 3 model layers + u2_can3 (:,km+nkc) = u2 (:,km ) ! after diffusion (nkt) + u2_can3 (:,km+2 ) = u2 (:,km-1) ! after diffusion (nkt) + u2_can3 (:,km+1 ) = u2 (:,km-2) ! after diffusion (nkt) + +! Top 3 combined layers NOT calculated in "sat_can": fill with top 3 model layers + v2_can3 (:,km+nkc) = v2 (:,km ) ! after diffusion (nkt) + v2_can3 (:,km+2 ) = v2 (:,km-1) ! after diffusion (nkt) + v2_can3 (:,km+1 ) = v2 (:,km-2) ! after diffusion (nkt) + +! Top 3 combined layers NOT calculated in "sat_can": fill with top 3 model layers + t2_can3 (:,km+nkc) = t2 (:,km ) ! after diffusion (nkt) + t2_can3 (:,km+2 ) = t2 (:,km-1) ! after diffusion (nkt) + t2_can3 (:,km+1 ) = t2 (:,km-2) ! after diffusion (nkt) + +! All tracers on combined layers after diffusion, for use in "canopy_to_resolved" + +! Top 3 combined layers NOT calculated in "sat_can": fill with top 3 model layers + q2_can3 (:,km+nkc , ntke ) = q2 (:,km , ntke ) ! after diffusion (nkt) + q2_can3 (:,km+2 , ntke ) = q2 (:,km-1 , ntke ) ! after diffusion (nkt) + q2_can3 (:,km+1 , ntke ) = q2 (:,km-2 , ntke ) ! after diffusion (nkt) + +! Top 3 combined layers NOT calculated in "sat_can": fill with top 3 model layers + q2_can3 (:,km+nkc , 1:ntrac1) = q2 (:,km , 1:ntrac1) ! nkt after diffusion (nkt) + q2_can3 (:,km+2 , 1:ntrac1) = q2 (:,km-1 , 1:ntrac1) ! nkt after diffusion (nkt) + q2_can3 (:,km+1 , 1:ntrac1) = q2 (:,km-2 , 1:ntrac1) ! nkt after diffusion (nkt) + +! Wind and temperature after diffusion + +! Combined layers (1,km) U-Wind/V-Wind/Temp after diffusion + u2_can3 (:,1:km) = u1_can (:,1:km) + du_can(:,1:km) * dt2 ! after diffusion (nkt) + v2_can3 (:,1:km) = v1_can (:,1:km) + dv_can(:,1:km) * dt2 ! after diffusion (nkt) + +! Combined layers (1,km) Temperature after diffusion + t2_can3 (:,1:km) = t1_can (:,1:km) + tdt_can(:,1:km) * dt2 ! after diffusion (nkt) +! t2_can (:,1:km) = t1_can (:,1:km) + tdt_can(:,1:km) * dt2 ! after diffusion (km) + +! Wind Speed after diffusion on canopy layers + ws2_can3(:,1:km) = sqrt(u2_can3(:,1:km)**2+v2_can3(:,1:km)**2) + +! 10m-interpolated wind ws1_can3 +! duv_can (:,1:km) = (ws2_can3(:,1:km) - ws1_can3(:,1:km)) * rdt ! 10m-interpolated ws1_can3 +! 1hy model layer wind ws1_can (1-4cy) + duv_can (:,1:km) = (ws2_can3(:,1:km) - ws1_can (:,1:km)) * rdt ! ws1_can is using 1hy model layer u1&v1(:,1) + +! Tracers after diffusion +! Subset (1:km) combined layers out of total ntk layers (NB. dim(:,nkt,:) <= dim(:,km,:) + q2_can3 (:,1:km, 1:ntrac1) = q1_can (:,1:km, 1:ntrac1) + + & rtg_can (:,1:km, 1:ntrac1) * dt2 ! after diffusion (nkt) +! TKE after diffusion + q2_can3 (:,1:km, ntke ) = q1_can (:,1:km, ntke ) + + & rtg_can (:,1:km, ntke ) * dt2 ! after diffusion (nkt) + q2_can (:,1:km, ntke ) = q1_can (:,1:km, ntke ) + + & rtg_can (:,1:km, ntke ) * dt2 ! after diffusion (km) + +! Apply minimum value on TKE tracer before "canopy_to_resolved" + q2_can3 (:,:, ntke) = max(q2_can3 (:,:, ntke), tkmin) ! after diffusion (nkt) + q2_can (:,:, ntke) = max(q2_can (:,:, ntke), tkmin) ! after diffusion (km) + +! Apply minimum value on humidity qmin before "canopy_to_resolved" and the tendency update + q2_can3 (:,:, ntqv) = max(q2_can3 (:,:, ntqv), qmin ) ! ntqv=1 + +! Apply minimum value on chemical conc before "canopy_to_resolved" + q2_can3 (:,:, ntoz:ntrac1 ) = + & max(q2_can3 (:,:, ntoz:ntrac1), concmin) + +! Top 3 combined layers set to resolved +! NB. Q2_can3 tracers array & t2_can3 after diffusion only updated 1:km + rho2_can3 (:,km+nkc) = prsl (:,km )/ ! after diffusion + & (rd*t2 (:,km )* + & (1.+fv*max(q2 (:,km , ntqv),qmin))) ! ntqv=1 + rho2_can3 (:,km+2 ) = prsl (:,km-1)/ ! after diffusion + & (rd*t2 (:,km-1)* + & (1.+fv*max(q2 (:,km-1, ntqv),qmin))) ! ntqv=1 + + rho2_can3 (:,km+1 ) = prsl (:,km-2)/ ! after diffusion + & (rd*t2 (:,km-2)* + & (1.+fv*max(q2 (:,km-2, ntqv),qmin))) ! ntqv=1 + +! Air density after diffusion on canopy layers + rho2_can3 (:,1:km ) = prsl_can3 (:,1:km)/ ! after diffusion + & (rd*t2_can3 (:,1:km)* + & (1.+fv*max(q2_can3 (:,1:km, ntqv),qmin))) ! ntqv=1 + + endif !do_canopy .and. cplaqm + + if (do_canopy) then + +!=============================================================================== +! Gather tracer concentration from canopy layers into model resolved layers (flag = 1) +!=============================================================================== + + CALL canopy_transfer_run(im, km, nkc, nkt, !in + & ntrac1, ntoz, !in + & garea, !in + & zi, zl, zm, !in + & q2, rho2, !in kg kg-1 + & 1, !in 1 = "canopy_to_resolved" + & FRT_MASK, !in + & kmod, kcan3, !in + & zmom_can3, zmid_can3, !in + & PRSL_CAN3, rho2_CAN3, !in + & Q2_MOD, Q2_CAN3, Q2_2M, !inout kg kg-1 after diffusion + & massair_can3, massair, !inout + & mmr_o3_can3, !inout + & nfrct, ifrct, !inout + & frctr2c, frctc2r, !inout + & errmsg, errflg ) + + if (errflg /= 0) return + +! ============== +! Input: +! Q2_CAN3(:,:, NLAYT, NSPCSD) : Chemical tracers mass conc. kg kg-1 on combined canopy+resolved layers after diffusion +! +! InOutput +! Q2_MOD(:,:, NLAYS, NSPCSD) : Chemical tracers mass conc. kg kg-1 on model levels after diffusion +! Q2 Canopy columns only!!! +! +! ================================ + + +! +! Canopy columns calculated in "canopy_to_resolved" +! +! Non-Canopy columns filled with resolved values +! + do k = 1, km + do i = 1,im + +! Non-canopy columns set to resolved values + IF (FRT_MASK(i) <= 0.) THEN + +! Non-canopy columns after "canopy_to_resolved" Line 1843: forrtl: error (78): process killed (SIGTERM) + q2_mod (i,k, 1:ntrac1) = q2(i,k, 1:ntrac1) ! after diffusion & after "canopy_to_resolved" + q2_mod (i,k, ntke ) = q2(i,k, ntke) ! after diffusion + + t2_mod (i,k) = t2 (i,k) ! after diffusion + u2_mod (i,k) = u2 (i,k) ! after diffusion + v2_mod (i,k) = v2 (i,k) ! after diffusion + + ws2_mod(i,k) = sqrt(u2_mod(i,k)**2+v2_mod(i,k)**2) ! after diffusion + + END IF ! (FRT_MASK) + end do ! i=1,im + end do ! k = 1, km-nkc + +! Apply minimum value on chemical conc after "canopy_to_resolved" + q2_mod (:,:, ntoz:ntrac1 ) = + & max(q2_mod (:,:, ntoz:ntrac1), concmin) ! after "canopy_to_resolved" + +! Apply minimum value on humidity qmin before doing canopy_transfer & update tendency + q2_mod(:,:, ntqv) = max(q2_mod(:,:, ntqv),qmin) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do k = 1, km1-1 ! from bottom to top resolved model levels + + kount=0 + ZOOOX(:) = 1. + do i = 1, im + +! Canopy columns/grid cells +! There is a contiguous forest canopy, calculated integrated canopy correction over model layers + IF ( FRT_MASK(i) > 0. ) THEN + + FCH = cfch(i) + +! Determine if canopy inside the model layer (kcan=1) or not (kcan=0) + IF (k .EQ. 1) THEN !use model layer interfaces + KCAN = 1 + ELSE + IF ( cfch(i) > zi(i,k) .AND. cfch(i) <= zi(i,k+1) ) THEN + KCAN = 1 + ELSE + KCAN= 0 + END IF + END IF + + IF (KCAN == 1 ) THEN !canopy inside model layer k + + ZI05 = zi(i,k+1) ! Initialize each model layer top that contains canopy (m) + ! Integrate across total model interface + ZFL = zi(i,k+1) ! Set ZFL = ZI05 + COUNTCAN = 0 ! Initialize canopy layers + + IF (k .EQ. 1) THEN !Find bottom in each model layer + BOTCAN = 0.0 + ELSE + BOTCAN = zi(i,k) + END IF + + DZFL = zi(i,k+1) - BOTCAN + +! Canopy inside model layer + DO WHILE (ZI05 .GE. BOTCAN) + +!!!!!!!!!!!!!!!!!!!!!!!! +! Steping down in-canopy zi_can3(:,1)= 0. + + do kc = nkt-1, 1, -1 ! from top to bottom combined canopy plus resolved model layers + +!!!!!!!!!!!!!!!!!!!!!!!! + +! Between two canopy layers + IF ( ZI05 > zi_can3(i,kc ) .and. + & ZI05 <= zi_can3(i,kc+1) ) THEN + + kc_can = kc + FZI05 = 1./ +! max(zi_can3 (i,kc+1) - +! & zi_can3 (i,kc), epsilon) * + & (zi_can3 (i,kc+1) - zi_can3 (i,kc)) * + & (ZI05 - zi_can3 (i,kc)) + + TTCORR = (t2_can3 (i,kc+1) - t2_can3 (i,kc))/ +! & max(zi_can3 (i,kc+1) - +! & zi_can3 (i,kc), epsilon) * + & (zi_can3 (i,kc+1) - zi_can3 (i,kc)) * + & (ZI05 - zi_can3 (i,kc)) + +! U-Wind/V-Wind after diffusion on canopy layers + UUCAN = u2_can3 (i,kc ) + + & (u2_can3 (i,kc+1) - u2_can3 (i,kc))/ +! & max(zi_can3 (i,kc+1) - +! & zi_can3 (i,kc), epsilon) * + & (zi_can3 (i,kc+1) - zi_can3 (i,kc)) * + & (ZI05 - zi_can3 (i,kc)) + + VVCAN = v2_can3 (i,kc ) + + & (v2_can3 (i,kc+1) - v2_can3 (i,kc))/ +! & max(zi_can3 (i,kc+1) - +! & zi_can3 (i,kc), epsilon) * + & (zi_can3 (i,kc+1) - zi_can3 (i,kc)) * + & (ZI05 - zi_can3 (i,kc)) +! Temperature after diffusion on canopy layers + TTCAN = t2_can3 (i,kc ) + + & (t2_can3 (i,kc+1) - t2_can3 (i,kc))/ +! & max(zi_can3 (i,kc+1) - +! & zi_can3 (i,kc), epsilon) * + & (zi_can3 (i,kc+1) - zi_can3 (i,kc)) * + & (ZI05 - zi_can3 (i,kc)) + + +! TKE after diffusion on canopy layers + TKECAN = q2_can3 (i,kc, ntke) + + & (q2_can3 (i,kc+1, ntke) - + & q2_can3 (i,kc , ntke))/ +! & max(zi_can3 (i,kc+1) - +! & zi_can3 (i,kc), epsilon) * + & (zi_can3 (i,kc+1) - zi_can3 (i,kc)) * + & (ZI05 - zi_can3 (i,kc)) + +! TKE half layers + TKEHCAN = tkeh_can (i,kc ) + + & (tkeh_can (i,kc+1) - tkeh_can (i,kc))/ +! & max(zi_can3(i,kc+1) - +! & zi_can3(i,kc), epsilon) * + & ( zi_can3(i,kc+1) - zi_can3(i,kc)) * + & (ZI05 - zi_can3(i,kc)) + + END IF ! "zi_can3(kc) < ZI05 <= zi_can3(kc+1)" + +!!!!!!!!!!!!!! +! End steping down in-canopy +! + end do ! kc = nkt-1, 1, -1 ! from top to bottom combined canopy plus resolved model layers +! +!!!!!!!!!!!!!! + +! IF ( ZI05 .LE. FCH ) THEN ! in-canopy layers (before Dec 2025) + IF ( ZI05 .LE. ZFL ) THEN ! Model layers + + COUNTCAN = COUNTCAN + 1 + ZCANX (COUNTCAN) = ZI05 + +! U-Wind/V-Wind after diffusion on model layer + UUX (COUNTCAN) = UUCAN + VVX (COUNTCAN) = VVCAN +! Temperature after diffusion on model layers + TTX (COUNTCAN) = TTCAN +! TKE on model layers + TKEX (COUNTCAN) = TKECAN +! TKE half layers on model layers + TKEHX(COUNTCAN) = TKEHCAN + + END IF ! ( ZI05 .LE. ZFL ) + + ZI05 = ZI05-0.5 !step down in-canopy resolution of 0.5m + + END DO ! DO WHILE (ZI05.GE.BOTCAN) + +! IntegrateTrapezoid = sum((y(1+1:n-0) + y(1+0:n-1))* +! & (x(1+1:n-0) - x(1+0:n-1)))/2 + ZZ_INT= IntegrateTrapezoid( + & ZCANX(COUNTCAN:1:-1), ZOOOX(COUNTCAN:1:-1)) + +! U-wind + UU_INT = IntegrateTrapezoid( + & ZCANX(COUNTCAN:1:-1) , + & UUX(COUNTCAN:1:-1) ) / +! & max(ZZ_INT, epsilon) + & ZZ_INT + +! V-wind + VV_INT = IntegrateTrapezoid( + & ZCANX(COUNTCAN:1:-1) , + & VVX(COUNTCAN:1:-1) ) / +! & max(ZZ_INT, epsilon) + & ZZ_INT + +! Temp + TT_INT = IntegrateTrapezoid( + & ZCANX(COUNTCAN:1:-1) , + & TTX(COUNTCAN:1:-1) ) / +! & max(ZZ_INT, epsilon) + & ZZ_INT + +! TKE + TKE_INT = IntegrateTrapezoid( + & ZCANX(COUNTCAN:1:-1) , + & TKEX(COUNTCAN:1:-1) ) / +! & max(ZZ_INT, epsilon) + & ZZ_INT + +! TKEH + TKEH_INT= IntegrateTrapezoid( + & ZCANX(COUNTCAN:1:-1) , + & TKEHX(COUNTCAN:1:-1) ) / +! & max(ZZ_INT, epsilon) + & ZZ_INT + +! Sum + TT_SUM = sum( TTX(COUNTCAN:1:-1))/COUNTCAN + +! U-wind/V-wind Canopy Columns + u2_mod (i,k) = UU_INT ! after "canopy-to-resolved" + v2_mod (i,k) = VV_INT ! after "canopy-to-resolved" + + ws2_mod(i,k) = sqrt(u2_mod(i,k)**2+v2_mod(i,k)**2) ! after "canopy-to-resolved" + +! Temperature Canopy Columns + t2_mod (i,k) = TT_INT ! after "canopy-to-resolved" + +! TKE Canopy Columns + q2_mod (i,k, ntke) = TKE_INT ! after "canopy-to-resolved" + q2_mod (i,k, ntke) = max(q2_mod (i,k, ntke), tkmin) ! after "canopy-to-resolved" + +! TKEH Canopy Columns + tkeh_mod(i,k) = TKEH_INT ! after "canopy-to-resolved" + tkeh_mod(i,k) = max(tkeh_mod(i,k), tkmin) +! Apply minimum value on TKE tracer before "canopy_to_resolved" + + END IF ! (KCAN .EQ. 1) model layer(s) containing canopy + + END IF ! contiguous canopy conditions + enddo ! i = 1, im + + kount = kount + 1 + + enddo ! k = 1, km1-1 ! from bottom to top resolved model levels + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Update ALL tracers with in-canopy tendencies (average sub-canopy values ) +! Here just wind components, temperature TKE, and interstitial tracers +! The chemical tracers are updated below with values from "canopy_to_resolved" transfer +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Update ALL model layer + do k = 1,km + + do i = 1,im + + ! Update Canopy columns only + IF (FRT_MASK(i) > 0.) THEN + +! Canopy Columns +! U-Wind/V-Wind after sub-canopy diffusion + du_mod (i,k) = (u2_mod (i,k) - u1 (i,k) )*rdt ! after "canopy_to_resolved" dim(km) + dv_mod (i,k) = (v2_mod (i,k) - v1 (i,k) )*rdt ! after "canopy_to_resolved" dim(km) + + duv_mod(i,k) = (ws2_mod(i,k) - ws1(i,k) )*rdt ! after "canopy_to_resolved" dim(km) + +! Temperature after sub-canopy diffusion + tdt_mod(i,k) = (t2_mod(i,k) - t1(i,k) )*rdt ! after "canopy_to_resolved" dim(km) + +! Tendency mass tracers after sub-canopy diffusion + rtg_mod(i,k, 1:ntrac1) = (q2_mod(i,k, 1:ntrac1) - + & q1 (i,k, 1:ntrac1))*rdt ! after "canopy_to_resolved" +! Tendency TKE tracer after sub-canopy diffusion + rtg_mod(i,k, ntke) = (q2_mod(i,k, ntke) - + & q1 (i,k, ntke) )*rdt ! after "canopy_to_resolved" + +!!!!!!!!!!!!!!!!!!!!! + + ENDIF ! (FRT_MASK) + enddo ! do i=1,im + enddo ! k=1,km + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Update Met & TKE & MP (microphysics) cloud fields +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Update all model layers + do k = 1,km + do i = 1,im + + IF (FRT_MASK(i) > 0.) THEN +! Tendency Wind components +! du (i,k) = du_mod (i,k) ! <<<<<<<========== UPDATE UU TEND =========>>>>>>> +! dv (i,k) = dv_mod (i,k) ! <<<<<<<========== UPDATE VV TEND =========>>>>>>> +! Tendency Temperature +! tdt(i,k) = tdt_mod(i,k) ! <<<<<<<========== UPDATE TT TEND =========>>>>>>> +! Tendency TKE (ntke=198) +! rtg(i,k, ntke) = rtg_mod(i,k, ntke) ! <<<<<<<========== UPDATE TKE TEND =========>>>>>>> + +! TKE half layers +! tkeh(i,k) = tkeh_mod(i,k) ! <<<<<<<========== UPDATE TKEH =========>>>>>>> + + ENDIF ! Contiguous canopy + enddo ! i + enddo !k + +! cloud/rain +! ------------------------ +! n=1 (ntqv) +! n=1 (ntcw) +! n=3 ... +! n=7 "o3mr" +! ------------- +!NTOZ do n = 1, ntoz +! do k = 1,km +! do i = 1,im +! IF (FRT_MASK(i) > 0.) THEN +! Humidity & Clouds +! rtg(i,k, n) = rtg_mod(i,k, n) ! <<<<<<<========== UPDATE MET TEND =========>>>>>>> +! rtg(i,k, ntqv) = rtg_mod(i,k, ntqv) ! <<<<<<<========== UPDATE VAP TEND =========>>>>>>> +! ENDIF ! Contiguous canopy +! enddo ! i +! enddo !k +!NTOZ enddo !n + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Update ONLY chemical tracers (n=8, ntrac1) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! All chemical tracers (n=9, ntrac1) +! ntqv=1-8 are cloud/rain and "sgs_tke" +! n=8 "no2" (ntchs=9) GFDL +! n=9 "no" GFDL +! n=10 "o3" GFDL +! ... +! NTRAC1 = 196 +! ---NO PBL TEND -------- +! n=197 ntche +! n=198 ntke +! ----------------------- + DO n = ntchs-1, ntche-1 ! 10, ntche-1 (same as NTRAC1) + +! Update all model layers + do k = 1,km + + do i = 1,im + IF (FRT_MASK(i) > 0.) THEN + +!!!!!!!!!!!!!!!!!!!!!!!!! +! Select all chemical tracers (selected tracers above) +!!!!!!!!!!!!!!!!!!!!!!!!! + rtg(i,k, n) = rtg_mod(i,k, n) ! <<<<<<<========== UPDATE TEND =========>>>>>>> + END IF + end do + + end do ! k = 1,km + end do ! n = 1, NTRAC1 + + endif !if(do_canopy) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> ## Save PBL height for diagnostic purpose +! + if (do_canopy) then + + do i = 1, im + hpbl(i) = hpbl_can(i) + kpbl(i) = kpbl_can(i) + enddo + + endif !do_canopy +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + return + end subroutine canopy_driver_run +!> @} + end module canopy_driver diff --git a/physics/PBL/SATMEDMF/canopy_driver.meta b/physics/PBL/SATMEDMF/canopy_driver.meta new file mode 100644 index 000000000..c7c974cd3 --- /dev/null +++ b/physics/PBL/SATMEDMF/canopy_driver.meta @@ -0,0 +1,949 @@ +[ccpp-table-properties] + name = canopy_driver + type = scheme + dependencies = ../../tools/funcphys.f90,../../tools/canopy_utils_mod.f,../../hooks/machine.F,../mfpbltq.f,mfscuq.f,../tridi.f,canopy_mask.F90,canopy_levs.F90,canopy_transfer.F90,satmedmfvdifq_can.F + +######################################################################## +[ccpp-arg-table] + name = canopy_driver_init + type = scheme +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[isatmedmf] + standard_name = choice_of_scale_aware_TKE_moist_EDMF_PBL + long_name = choice of scale-aware TKE moist EDMF PBL scheme + units = none + dimensions = () + type = integer + intent = in +[isatmedmf_vdifq] + standard_name = choice_of_updated_scale_aware_TKE_moist_EDMF_PBL + long_name = choice of updated scale-aware TKE moist EDMF PBL scheme + units = none + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +##################################################################### +[ccpp-arg-table] + name = canopy_driver_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[km] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_vertical_diffusion_tracers + long_name = number of tracers to diffuse vertically + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_for_liquid_cloud_condensate_vertical_diffusion_tracer + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_for_rain_water_vertical_diffusion_tracer + long_name = tracer index for rain water in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_for_ice_cloud_condensate_vertical_diffusion_tracer + long_name = tracer index for ice water in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[ntke] + standard_name = index_for_turbulent_kinetic_energy_vertical_diffusion_tracer + long_name = index for turbulent kinetic energy in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[ntchm] + standard_name = number_of_chemical_tracers + long_name = number of chemical tracers + units = count + dimensions = () + type = integer + intent = in +[ntchs] + standard_name = index_of_first_chemical_tracer_in_tracer_concentration_array + long_name = tracer index for first chemical tracer + units = index + dimensions = () + type = integer + intent = in +[ntche] + standard_name = index_for_last_chemical_tracer + long_name = tracer index for last chemical tracer + units = index + dimensions = () + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[nto3] + standard_name = index_for_ozone_chemical_tracer_in_tracer_concentration_array + long_name = tracer index for ozone chemical tracer + units = index + dimensions = () + type = integer + intent = in +[ndtend] + standard_name = cumulative_change_of_state_variables_outer_index_max + long_name = last dimension of array of diagnostic tendencies for state variables + units = count + dimensions = () + type = integer + intent = in +[con_rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[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 +[rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[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 +[hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[fv] + 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 +[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 +[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 +[dv] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[du] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[tdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[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_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = inout +[u1] + standard_name = x_wind + long_name = x component of layer wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[v1] + standard_name = y_wind + long_name = y component of layer wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[usfco] + standard_name = x_ocean_current + long_name = zonal current at ocean surface + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[vsfco] + standard_name = y_ocean_current + long_name = meridional current at ocean surface + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[use_oceanuv] + standard_name = do_air_sea_flux_computation_over_water + long_name = air-sea flux option + units = flag + dimensions = () + type = logical + intent = in +[t1] + standard_name = air_temperature + long_name = layer mean air temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q1] + standard_name = vertically_diffused_tracer_concentration + long_name = tracer concentration diffused by PBL scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = in +[def_1] + standard_name = square_of_vertical_shear_due_to_dynamics + long_name = square of vertical shear calculated from dynamics + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[def_2] + standard_name = square_of_horizontal_shear_due_to_dynamics + long_name = square of horizontal shear calculated from dynamics + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[def_3] + standard_name = horizontal_transfer_rate_of_tke_due_to_dynamics + long_name = rate of horizontal TKE transfer and pressure correlation calculated from dynamics + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[swh] + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky shortwave heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[hlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky longwave heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[xmu] + standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes + long_name = zenith angle temporal adjustment factor for shortwave + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[psk] + standard_name = surface_dimensionless_exner_function + long_name = dimensionless Exner function at the surface interface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rbsoil] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[u10m] + standard_name = x_wind_at_10m + long_name = x component of wind at 10 m + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v10m] + standard_name = y_wind_at_10m + long_name = y component of wind at 10 m + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t2m] + standard_name = air_temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[q2m] + standard_name = specific_humidity_at_2m + long_name = 2 meter specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum + long_name = Monin-Obukhov similarity function for momentum + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[fh] + standard_name = Monin_Obukhov_similarity_function_for_heat + long_name = Monin-Obukhov similarity function for heat + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsea] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[heat] + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[evap] + standard_name = surface_upward_specific_humidity_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[stress] + standard_name = surface_wind_stress + long_name = surface wind stress + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[spd1] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = PBL top model level index + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = pres(k) - pres(k+1) + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prslk] + standard_name = dimensionless_exner_function + long_name = Exner function at layers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[delt] + standard_name = timestep_for_physics + long_name = time step for physics + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[tte_edmf] + standard_name = flag_for_scale_aware_TTE_moist_EDMF_PBL + long_name = flag for scale-aware TTE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[dspheat] + standard_name = flag_TKE_dissipation_heating + long_name = flag for using TKE dissipation heating + units = flag + dimensions = () + type = logical + intent = in +[sa3dtke] + standard_name = do_scale_aware_3d_tke + long_name = flag for scale-aware 3d tke scheme + units = flag + dimensions = () + type = logical + intent = in +[dusfc] + standard_name = instantaneous_surface_x_momentum_flux + long_name = x momentum flux + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dvsfc] + standard_name = instantaneous_surface_y_momentum_flux + long_name = y momentum flux + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dtsfc] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dqsfc] + standard_name = instantaneous_surface_upward_latent_heat_flux + long_name = surface upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tkeh] + standard_name = vertical_turbulent_kinetic_energy_at_interface + long_name = vertical turbulent kinetic energy at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[dkt] + standard_name = atmosphere_heat_diffusivity + long_name = atmospheric heat diffusivity + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[dku] + standard_name = atmosphere_momentum_diffusivity + long_name = atmospheric momentum diffusivity + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[dkt_can] + standard_name = atmosphere_heat_diffusivity_in_canopy + long_name = atmospheric heat diffusivity in canopy + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dku_can] + standard_name = atmosphere_momentum_diffusivity_in_canopy + long_name = atmospheric momentum diffusivity in canopy + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dku3d_h] + standard_name = horizontal_atmosphere_momentum_diffusivity_for_dynamics + long_name = horizontal atmospheric momentum diffusivity for dynamics + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dku3d_e] + standard_name = horizontal_atmosphere_tke_diffusivity_for_dynamics + long_name = horizontal atmospheric tke diffusivity for dynamics + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[xkzm_m] + standard_name = atmosphere_momentum_diffusivity_due_to_background + long_name = background value of momentum diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[xkzm_h] + standard_name = atmosphere_heat_diffusivity_due_to_background + long_name = background value of heat diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[xkzm_s] + standard_name = sigma_pressure_threshold_at_upper_extent_of_background_diffusion + long_name = sigma level threshold for background diffusivity + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dspfac] + standard_name = multiplicative_tuning_parameter_for_tke_dissipative_heating + long_name = tke dissipative heating factor + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[bl_upfr] + standard_name = updraft_area_fraction_in_scale_aware_tke_moist_edmf_pbl_scheme + long_name = updraft fraction in boundary layer mass flux scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[bl_dnfr] + standard_name = downdraft_area_fraction_in_scale_aware_tke_moist_edmf_pbl_scheme + long_name = downdraft fraction in boundary layer mass flux scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[rlmx] + standard_name = maximum_allowed_mixing_length_in_boundary_layer_mass_flux_scheme + long_name = maximum allowed mixing length in boundary layer mass flux scheme + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[elmx] + standard_name = maximum_allowed_dissipation_mixing_length_in_boundary_layer_mass_flux_scheme + long_name = maximum allowed dissipation mixing length in boundary layer mass flux scheme + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[do_canopy] + standard_name = flag_for_canopy_option + long_name = flag for in-canopy eddy diffusivity adjustment option + units = flag + dimensions = () + type = logical + intent = in +[cplaqm] + standard_name = flag_for_air_quality_coupling + long_name = flag controlling cplaqm collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[claie] + standard_name = canopy_leaf_area_index + long_name = canopy leaf area index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cfch] + standard_name = canopy_forest_height + long_name = canopy forest height + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cfrt] + standard_name = canopy_forest_fraction + long_name = canopy forest fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cclu] + standard_name = canopy_clumping_index + long_name = canopy clumping index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cpopu] + standard_name = canopy_population_density + long_name = population density used for canopy correction + units = km-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[sfc_rlm] + standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme + long_name = choice of near surface mixing length in boundary layer mass flux scheme + units = none + dimensions = () + type = integer + intent = in +[tc_pbl] + standard_name = control_for_TC_applications_in_the_PBL_scheme + long_name = control for TC applications in the PBL scheme + units = none + dimensions = () + type = integer + intent = in +[use_lpt] + standard_name = control_for_using_LPT_for_TC_applications_in_the_PBL_scheme + long_name = control for using LPT in TC applications in the PBL scheme + units = none + dimensions = () + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout + optional = True +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_pbl] + standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index + long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[gen_tend] + standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +#[naux2d] +# standard_name = number_of_xy_dimensioned_auxiliary_arrays +# long_name = number of 2d auxiliary arrays to output (for debugging) +# units = count +# dimensions = () +# type = integer +# intent = out +#[naux3d] +# standard_name = number_of_xyz_dimensioned_auxiliary_arrays +# long_name = number of 3d auxiliary arrays to output (for debugging) +# units = count +# dimensions = () +# type = integer +# intent = out +#[aux2d] +# standard_name = auxiliary_2d_arrays +# long_name = auxiliary 2d arrays to output (for debugging) +# units = none +# dimensions = (horizontal_loop_extent,number_of_xy_dimensioned_auxiliary_arrays) +# type = real +# kind = kind_phys +# intent = out +#[aux3d] +# standard_name = auxiliary_3d_arrays +# long_name = auxiliary 3d arrays to output (for debugging) +# units = none +# dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_xyz_dimensioned_auxiliary_arrays) +# type = real +# kind = kind_phys +# intent = out diff --git a/physics/PBL/SATMEDMF/canopy_levs.F90 b/physics/PBL/SATMEDMF/canopy_levs.F90 new file mode 100644 index 000000000..ce9f74136 --- /dev/null +++ b/physics/PBL/SATMEDMF/canopy_levs.F90 @@ -0,0 +1,1285 @@ + module canopy_levs_mod + contains + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + + subroutine canopy_levs_init(im, km, nkc, nkt, & + ntrac, ntqv, ntke, & ! ndtend, & + zi, zl, zm, & ! in: 3D meters + prsl, prsi, & ! in: 3D (Pa) + dv, du, tdt, rtg, & ! in: 3D + U1, V1, T1, Q1, & ! in: 3D " 4D q1(ix,km,ntrac1) kg kg-1 + dens, dkt, dku, & ! in: 3D +! dtend, & ! in: 4D + zmom_can3, zmid_can3, & !out: 3D + sigmom_can, sigmid_can, & !out + ZL_CAN, ZM_CAN, & !out + PRSL_CAN, PRSI_CAN, & !out + dv_can, du_can, tdt_can, rtg_can, & !out: 3D + T1_CAN, QV_CAN, DENS_CAN, & !out + WS_CAN, DKT_CAN, DKU_CAN, & !out + Q1_CAN, Q1_2M, & !out +! DTEND_CAN, & + errmsg, errflg ) !out + + use machine , only : kind_phys + + IMPLICIT NONE + +!...Arguments: + integer, intent(in) :: im, km, nkc, nkt, ntrac, ntqv, ntke !, ndtend + + real(kind=kind_phys), intent(in) :: zi(im, km+1), zl(im, km), & + zm(im, km), & + prsi(im, km+1), prsl(im, km) + real(kind=kind_phys), intent(in) :: dv(im, km), du(im, km), & + tdt(im, km), rtg(im, km,ntrac) + real(kind=kind_phys), intent(in) :: u1(im, km), v1(im, km), t1(im,km) + real(kind=kind_phys), intent(in) :: dens(im, km), dkt(im, km), dku(im,km) +! real(kind=kind_phys), intent(in) :: dtend(im, km , ndtend) + +! ** Q1 is concentration field (including gas and aerosol variables) mass mixing ratio kg kg-1 + real(kind=kind_phys), intent(in) :: Q1(im, km, ntrac) + + real(kind=kind_phys), intent(out) :: & +! tendencies +! DTEND_CAN (im, km , ndtend), & + dv_can (im, km) , & + du_can (im, km) , & + tdt_can (im, km) , & +! tendencies all gas-phase species & TKE + RTG_CAN (im, km, ntrac) , & + +! met3d arrays + ZL_CAN (im, nkt) , & ! dim(nkt) + ZM_CAN (im, nkt) , & ! dim(nkt) + T1_CAN (im, nkt) , & ! dim(nkt) + QV_CAN (im, nkt) , & ! dim(nkt) + WS_CAN (im, nkt) , & ! dim(nkt) + PRSL_CAN (im, nkt) , & ! dim(nkt) + PRSI_CAN (im, nkt+1) , & ! dim(nkt+1) + DENS_CAN (im, nkt) , & ! dim(nkt) + DKT_CAN (im, nkt) , & ! dim(nkt) + DKU_CAN (im, nkt) , & ! dim(nkt) +! all gas-phase species array + Q1_CAN (im, nkt, ntrac) , & ! dim(nkt) + Q1_2M (im, ntrac) , & ! +! canopy layers height arrays + zmom_can3 (im, nkt) , & ! dim(nkt+1) ! Paul's sigmcan(:,nkt) + zmid_can3 (im, nkt) , & ! dim(nkt) ! Paul's sigtcan(:,nkt) + sigmom_can(im, nkt+1) , & ! dim(nkt) ~ prsi(:,km+1) + sigmid_can(im, nkt) ! dim(nkt) ~ prsl(:,km) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!...local variables + + integer :: k, kc + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! Initialize with values before in-canopy diffusion + +! Layers height + zmom_can3 (:,:) = 0. + zmid_can3 (:,:) = 0. + sigmom_can(:,:) = 0. + sigmid_can(:,:) = 0. + +! Zero in-canopy tendencies +! dtend_can(:, :, : ) = 0.0 + +! Tracers + Q1_2M (:, :) = Q1(:,1, :) ! kg kg-1 + +! Subset (km combined layers minus top nkc layers) + do k = 1, km-nkc + + ! km is top combined subset + ! nkc+1 is bot combined + kc= nkc+k ! 4th from top (nkt) to nkc+1 combined canopy plus resolved model layer + +! Tendencies + DU_CAN (:,kc) = DU (:,k) ! m s-2 + DV_CAN (:,kc) = DV (:,k) ! m s-2 + TDT_CAN (:,kc) = TDT (:,k) ! K s-1 + + RTG_CAN (:,kc, 1:ntrac-1) = RTG (:,k, 1:ntrac-1) ! kg kg-1 s-1 + RTG_CAN (:,kc, ntke ) = RTG (:,k, ntke ) ! J s-1 s-1 + + end do + +! All combined canopy plus resolved layers + do k = 1, km + + ! nkc+km is top (nkt) combined + ! nkc+1 is bot combined + kc= nkc+k ! top (nkt) to nkc+1 combined canopy plus resolved model layer + +! Height + ZL_CAN (:,kc) = zl (:,k) + ZM_CAN (:,kc) = zm (:,k) + +! Pressure & temperature + prsl_can(:,kc) = prsl(:,k) ! km combined canopy plus resolved layers + prsi_can(:,kc) = prsi(:,k) ! km combined canopy plus resolved layers + T1_CAN (:,kc) = T1 (:,k) + DENS_CAN(:,kc) = DENS(:,k) + +! Diffusivities + DKT_CAN (:,kc) = DKT (:,k) ! m2 s-1 + DKU_CAN (:,kc) = DKU (:,k) ! m2 s-1 + +! Wind + WS_CAN (:,kc) = sqrt(u1(:,k)**2+v1(:,k)**2) ! m s-1 + +! Mass tracers + Q1_CAN (:,kc, 1:ntrac-1) = Q1 (:,k, 1:ntrac-1) ! all tracers ntrac1 + +! TKE tracer + Q1_CAN (:,kc, ntke ) = Q1 (:,k, ntke ) ! ntke=198 TKE tracer + +! Humidity + QV_CAN(:,kc) = Q1(:,k, ntqv) ! ntqv=1 + + end do + prsi_can(:,km + nkc +1 ) = prsi(:,km+1) ! nkt combined canopy plus resolved layers + +! Canopy layers + do kc = 1, nkc ! 3-nkc canopy layers + +! Tendencies + DU_CAN (:,kc) = DU (:,1) ! m s-2 + DV_CAN (:,kc) = DV (:,1) ! m s-2 + TDT_CAN (:,kc) = TDT (:,1) ! K s-1 + + RTG_CAN (:,kc, 1:ntrac-1) = RTG (:,1, 1:ntrac-1) ! kg kg-1 s-1 + RTG_CAN (:,kc, ntke ) = RTG (:,1, ntke ) ! J s-1 s-1 + +! Height + ZL_CAN (:,kc) = zl (:,1) + ZM_CAN (:,kc) = zm (:,1) + +! Pressure & temperature + prsl_can(:,kc) = prsl(:,1) ! km combined canopy plus resolved layers + prsi_can(:,kc) = prsi(:,1) ! km combined canopy plus resolved layers + T1_CAN (:,kc) = T1 (:,1) + DENS_CAN(:,kc) = DENS(:,1) + +! Diffusivities + DKT_CAN (:,kc) = DKT (:,1) ! m2 s-1 + DKU_CAN (:,kc) = DKU (:,1) ! m2 s-1 + +! Wind + WS_CAN (:,kc) = sqrt(u1(:,1)**2+v1(:,1)**2) ! m s-1 + +! Mass tracers + Q1_CAN (:,kc, 1:ntrac-1) = Q1 (:,1, 1:ntrac-1) ! all tracers ntrac1 + +! TKE tracer + Q1_CAN (:,kc, ntke ) = Q1 (:,1, ntke ) ! ntke=198 TKE tracer + +! Water vapor + QV_CAN (:,kc) = Q1(:,1, ntqv) ! ntqv=1 + + end do + + end subroutine canopy_levs_init + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + + subroutine canopy_levs_run(im, km, nkc, nkt, & + ntrac, ntqv, ntke, & ! in + RDGAS, PI, & ! in ?? units ?? + zi, zl, zm, & ! in: 1D zm(i,k) = zi(i,k+1) + prsl, prsi, psfc, & ! in: 3D 3D 2D (Pa) + cfch, & ! in: 2D + garea, u10m, v10m, fm,fh, & ! in: 2D + rbsoil, & ! in: 2D + T2M, Q2M, & ! in: 2D + stress, spd1, & ! in: 2D + dv, du, tdt, rtg, & ! in: 3D + U1, V1, T1, Q1, & ! in: 3D " 4D + DENS, dkt, dku, & ! in 3D + FRT_MASK, & ! in 2D + kmod, kcan3, & ! out + zmom_can3, zmid_can3, & ! out zmom_can3 (:, nkt) zmid_can3(im, nkt) + sigmom_can, sigmid_can, & ! out 3D sigmom_can(:, nkt) sigmid_can(im, nkt) + ZL_CAN, ZM_CAN, & ! out 3D + PRSL_CAN, PRSI_CAN, & ! out 3D prsi_can (:, nkt+1) + dv_can, du_can, tdt_can, rtg_can, & ! out: 3D + T1_CAN, QV_CAN, DENS_CAN, & ! out 3D + WS_CAN, DKT_CAN, DKU_CAN, & ! out 3D + Q1_CAN, Q1_2M, & !out + errmsg,errflg) + + use machine , only : kind_phys + + IMPLICIT NONE + +! Includes: + +!...Arguments: + + integer, intent(in) :: im, km, nkc, nkt, ntrac, ntqv, ntke + real(kind=kind_phys), intent(in) :: RDGAS, PI + + real(kind=kind_phys), intent(in) :: zi(im,km+1), zl(im,km), & + zm(im,km), & + prsi(im,km+1), prsl(im,km) + real(kind=kind_phys), intent(in) :: dv(im,km), du(im,km), & + tdt(im,km), rtg(im,km,ntrac) + + real(kind=kind_phys), intent(in) :: u1(im,km), v1(im,km), t1(im,km) + real(kind=kind_phys), intent(in) :: dens(im,km), dkt(im,km), dku(im,km) + + real(kind=kind_phys), intent(in) :: psfc(im) ! Pa + real(kind=kind_phys), intent(in) :: cfch(im), garea(im), u10m(im), v10m(im), & + spd1(im),stress(im), & + t2m(im), q2m(im), fm(im), fh(im), & + rbsoil(im) + +! ** Q1 is concentration field (including gas and aerosol variables) kg kg-1 + real(kind=kind_phys), intent(in) :: q1(im, km, ntrac) + + real(kind=kind_phys), intent(in) :: FRT_mask(im) + + integer, intent(out) :: kmod (im, km) , kcan3 (im, nkc) + + real(kind=kind_phys), intent(out) :: & +! tendencies + dv_can (im, km) , & + du_can (im, km) , & + tdt_can (im, km) , & +! tendencies all gas-phase species & TKE + RTG_CAN (im, km, ntrac) , & +! met3d arrays + ZL_CAN (im, nkt) , & + ZM_CAN (im, nkt) , & + T1_CAN (im, nkt) , & + QV_CAN (im, nkt) , & + WS_CAN (im, nkt) , & + PRSL_CAN (im, nkt) , & + PRSI_CAN (im, nkt+1) , & + DENS_CAN (im, nkt) , & + DKT_CAN (im, nkt) , & + DKU_CAN (im, nkt) , & +! all gas-phase species array + Q1_CAN (im, nkt, ntrac) , & + Q1_2M (im, ntrac) , & +! canopy layers height arrays + zmom_can3 (im, nkt) , & ! Paul's sigmcan(:,nkt) + zmid_can3 (im, nkt) , & ! Paul's sigtcan(:,nkt) + sigmom_can(im, nkt+1) , & ! ~ prsi(:,km+1) + sigmid_can(im, nkt) ! ~ prsl(:,km) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!...Local arrays: + + integer(kind=4) :: kcan_top + real (kind=kind_phys) :: hcan + + logical :: sfcflg(im) + + integer(kind=4) :: ka (im) , & + kl (im) + + real(kind=kind_phys) :: zmid3 (km) , & + zmom3 (km) , & ! Paul's zfull + sigmom3 (km+1), & + z2 (km+1), & ! Paul's z2(:,chm_nk+1) + sigmid2 (km+1), & ! Paul's sigt2(:,chm_nk+1) + zcan3 (nkc), & + ta_can3 (nkt), ta3 (km) , & + qv_can3 (nkt), qv3 (km) , & + ws_can3 (nkt), ws3 (km) , & + dkt_can3 (nkt), dkt3 (km) , & + dku_can3 (nkt), dku3 (km) , & + prsl_can3 (nkt), prsl3 (km) , & + prsi_can3 (nkt+1), prsi3 (km+1), & + dens_can3 (nkt), dens3 (km) , & + mol3 (km) , & + klower_can(nkc) + + real(kind=kind_phys) :: & + dxdy (im), ustar (im), & + ws10m (im), & + zol (im), ilmo (im), & + safe_inv_mo_length(im) + +!...local variables + + INTEGER :: i,L + + logical(kind=4) :: flag_error + integer(kind=4) :: k, kk, kc, k2, II, npass + + real(kind=kind_phys) :: tmp + real(kind=kind_phys) :: hol, a1, b1, c1, rat + +! del: Minimum allowable distance between a resolved model layer and a canopy layer +! (fraction of canopy layer height) + real(kind=kind_phys), parameter :: del = 0.2 + real(kind=kind_phys), parameter :: min_kt = 0.1 + real(kind=kind_phys), parameter :: zfmin=1.e-8 + real(kind=kind_phys), parameter :: rimin=-100. + real(kind=kind_phys), parameter :: karman=0.4 ! von karman constant + real(kind=kind_phys), parameter :: THRESHOLD = 1.e06 ! MOL threshold, similar to mach_plumerise + real(kind=kind_phys), parameter :: epsilon = 1.e-10 + + real(kind=kind_phys) :: zm2, zr, td, hd, ddel + real(kind=kind_phys) :: uh, uspr, wndr, sigw, tl, ktr, kur + +! Assign the fractional heights of the canopy layers (fraction of canopy height) + real(kind=kind_phys), dimension(3), parameter :: can_frac = (/1.0, 0.5, 0.2/) + + logical(kind=4) :: local_dbg + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + local_dbg = (.false.) + + kmod (:,:) = -999 + kcan3(:,:) = -999 + +! Initializations + +! NB. mfpbltq_mod: q1(ix,km,ntrac1) kg kg-1 + Q1_2M (:, :) = Q1(:,1,:) ! kg kg-1 + +! Subset (km combined layers minus top nkc layers) + do k = 1, km-nkc + ! km is top combined subset + ! nkc+1 is bot combined + kc= nkc+k ! 4th from top (nkt) to nkc+1 combined canopy plus resolved model layer + +! PBL Tendencies are declared in CCPP_typdefs as dim(im,km) instead (im, nkt) + DU_CAN (:,kc) = DU (:,k) ! m s-2 + DV_CAN (:,kc) = DV (:,k) ! m s-2 + TDT_CAN (:,kc) = TDT (:,k) ! K s-1 + + RTG_CAN (:,kc, 1:ntrac-1) = RTG (:,k, 1:ntrac-1) ! kg kg-1 s-1 + RTG_CAN (:,kc, ntke ) = RTG (:,k, ntke ) ! J s-1 s-1 + + end do + +! All combined canopy plus resolved layers + do k = km, 1, -1 ! top to 1hy model layer + ! nkc+km is top (nkt) combined + ! nkc+1 is bot combined + kc= nkc+k ! top (nkt) to nkc+1 combined canopy plus resolved model layer + +! Pressure & Temperature + prsl_can(:,kc) = prsl(:,k) ! km combined canopy plus resolved layers + prsi_can(:,kc) = prsi(:,k) ! km combined canopy plus resolved layers + T1_CAN (:,kc) = T1 (:,k) + DENS_CAN(:,kc) = DENS(:,k) + +! Diffusivities + DKT_CAN (:,kc) = DKT (:,k) ! m2 s-1 + DKU_CAN (:,kc) = DKU (:,k) ! m2 s-1 + +! Wind + WS_CAN (:,kc) = sqrt(u1(:,k)**2+v1(:,k)**2) ! m s-1 + +! Mass tracers + Q1_CAN (:,kc, 1:ntrac-1) = Q1 (:,k, 1:ntrac-1) ! all tracers ntrac1 + +! TKE tracer + Q1_CAN (:,kc, ntke ) = Q1 (:,k, ntke ) ! ntke=198 TKE tracer + +! Water vapor + QV_CAN(:,kc) = Q1(:,k, ntqv) ! ntqv=1 + + end do + prsi_can(:,nkt+1 ) = prsi(:,km+1) ! km combined canopy plus resolved layers + +! Canopy layers + do kc = 1, nkc ! 3-nkc canopy layers + + DU_CAN (:,kc) = DU (:,1) ! m s-2 + DV_CAN (:,kc) = DV (:,1) ! m s-2 + TDT_CAN (:,kc) = TDT (:,1) ! K s-1 + + RTG_CAN (:,kc, 1:ntrac-1) = RTG (:,1, 1:ntrac-1) ! kg kg-1 s-1 + RTG_CAN (:,kc, ntke ) = RTG (:,1, ntke ) ! J s-1 s-1 + + prsl_can(:,kc) = prsl(:,1) ! km combined canopy plus resolved layers + prsi_can(:,kc) = prsi(:,1) ! km combined canopy plus resolved layers + T1_CAN (:,kc) = T1 (:,1) + DENS_CAN(:,kc) = DENS(:,1) + + DKT_CAN (:,kc) = DKT (:,1) ! m2 s-1 + DKU_CAN (:,kc) = DKU (:,1) ! m2 s-1 + WS_CAN (:,kc) = sqrt(u1(:,1)**2+v1(:,1)**2) ! m s-1 + +! Mass tracers + Q1_CAN (:,kc, 1:ntrac-1) = Q1 (:,1, 1:ntrac-1) ! all tracers ntrac-1 + +! TKE tracer + Q1_CAN (:,kc, ntke ) = Q1 (:,1, ntke ) ! ntke=198 TKE tracer + +! Water vapor + QV_CAN (:,kc) = Q1(:,1, ntqv) ! ntqv=1 + + end do + + + DO i = 1, im + + sfcflg(i)= .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + + dxdy(i) = garea( i ) ! dx*dy ~1.6E+8 m2 + + ustar(i) = sqrt(stress(i)) +! ws10m(i) = sqrt(u10m(i)**2+v10m(i)**2) + +!> ## Compute Monin-Obukhov similarity parameters +!! - Calculate the Monin-Obukhov nondimensional stability paramter, commonly +!! referred to as \f$\zeta\f$ using the following equation from Businger et al.(1971) \cite businger_et_al_1971 +!! (eqn 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. + 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 +! Inverse of Monin-Obukhov length + ilmo(i) = 1./zol(i) + +!!!! Non-Canopy columns + IF (FRT_mask(i) <= 0.) THEN + + do k = 1, km ! from bottom to top + II = km + 1 - k ! from top to bottom of resolved model layers +!!! Paul's zmom is our zmom +! zmom(1) = ZFULL(km) is top model layer height +! zmom(km) = ZFULL(1) is bottom model layer height + ! NB. zm(:,k) = zi(:,k+1) + zmom3(II) = zm(i,k) ! ZFULL(i,k) +!! Heights of the original model layers for the canopy columns are extracted to the zmom array. + + ! Create temperature & humidity array on reversed layer order for interpolation + ta3 (II) = T1 (i,k) ! K + qv3 (II) = Q1 (i,k,1) ! 1=water vapor kg kg-1 + prsl3(II) = PRSL(i,k) ! Pa mean layer pressure + dens3(II) = DENS(i,k) ! kg m-3 + ws3 (II) = sqrt(u1(i,k)**2+v1(i,k)**2) ! rename wspd3 ??? + dkt3 (II) = DKT (i,k) ! m2 s-2 + dku3 (II) = DKU (i,k) ! m2 s-2 + end do ! k = 1, km ! from bottom to top + + do k = 1, km+1 ! from bottom to top + II = (km + 1) + 1 - k ! from top to bottom of resolved model layers + + prsi3 (II) = PRSI(i,k) ! Pa air pressure at model layer interfaces +! ! [pgr] surface air pressure meta var + sigmom3(II) = PRSI(i, k) / psfc(i) ! PRES_FULL + end do ! k = 1, km+1 + +! First, carry over original model values for the matching layers + do k = 1, km ! from bottom to top of resolved model layers + ! kmod(1) is 1 top model layer + ! kmod(km) is 65 top canopy layer (modified after mono adj.) + kk = k ! kmod(i,k) + + sigmom_can(i, kk) = sigmom3(k) ! + + ta_can3 (kk) = ta3 (k) ! TA (i, k) ! temperature [K] + qv_can3 (kk) = qv3 (k) ! Met_Data%QV (i, k) ! spec. humidity + prsl_can3(kk) = prsl3(k) ! Met_Data%PRES(i, k) ! Pa + prsi_can3(kk) = prsi3(k) ! + dens_can3(kk) = dens3(k) ! Met_Data%DENS(i, k) ! kg m-3 + ws_can3 (kk) = ws3 (k) ! ! m s-1 + dkt_can3 (kk) = dkt3 (k) ! DKT (i, k) ! m2 s-2 atmos. thermal diffus. + dku_can3 (kk) = dku3 (k) ! DKU (i, k) ! m2 s-2 atmos. momentum diffus. + end do + + do kc = 1, nkc ! from top to bottom of canopy layers + ! kk = 65 = kcan3(1) = km + 1 + ! kk = 66 = kcan3(2) = km + 2 + ! kk = 67 = kcan3(3) = km + 3 + kk = kc + km ! kcan3(i,kc) + +! zmom_can3 (i, kk) = zmom3 (km) ! full layer height [m] + sigmom_can(i, kk) = sigmom3(km) ! + + ta_can3 (kk) = ta3 (km) ! TA (i, k) ! temperature [K] + qv_can3 (kk) = qv3 (km) ! Met_Data%QV (i, k) ! spec. humidity + prsl_can3(kk) = prsl3(km) ! Met_Data%PRES(i, k) ! Pa + prsi_can3(kk) = prsi3(km) + dens_can3(kk) = dens3(km) ! Met_Data%DENS(i, k) ! kg m-3 + ws_can3 (kk) = ws3 (km) ! ! m s-1 + dkt_can3 (kk) = dkt3 (km) ! DKT (i, k) ! m2 s-2 atmos. thermal diffus. + dku_can3 (kk) = dku3 (km) ! DKU (i, k) ! m2 s-2 atmos. momentum diffus. + end do +! Lower interface at surface + prsi_can3 ( nkt+1) = prsi3(km+1) + sigmom_can(i, nkt+1) = 1.0 + +!!!!! End non-canopy columns!!!!! + + ! Continuous forest canopy + ELSE IF (FRT_mask(i) > 0.) THEN + + hcan = cfch( i ) +!!! Extract the canopy height (FCH) + +! Generate initial canopy levels, as altitude above sea level +! + do kc = 1, nkc + zcan3(kc) = hcan * can_frac(kc) ! Paul's hc is our hcan + ! Paul's zcan is our zcan3 +!!! Set the initial values of the heights of the inserted canopy layers to hc, 0.5 hc, and 0.2 hc +!!! +!!! NB. zcan3(1) is hc, top of canopy +!!! zcan3(2) is 0.5 * hc +!!! zcan3(3) is 0.2 * hc (bottom canopy level) +! +! print*,'canopy_levs: ZCAN = ', i, kc, zcan3(kc) + end do + +! 1 = bottom (1st) model layer +! km= top model layer + do k = 1, km ! from bottom to top + II = km + 1 - k ! from top to bottom of resolved model layers +! zl is height of layer center +! zmid3(1) = zl(km) is top model layer height +! zmid3(km) = zl(1) is bottom model layer height + ! Paul's zt is our zmid + zmid3(II) = ZL(i,k) ! mid layer height [m] +!!! Heights of the original model layers for the canopy columns are extracted to the zmid array. + +! write(errmsg,*) 'canopy_levs: ZMID = ', i, II, zmid3(II) + + ! Paul's sigt2 is our sigmid2 + sigmid2(II) = prsl(i,k)/ psfc(i) + + end do + sigmid2(km+1) = 1.0 + + do k = 1, km ! from bottom to top + II = km + 1 - k ! from top to bottom of resolved model layers +!!! Paul's zmom is our zmom +! zmom(1) = ZFULL(km) is top model layer height +! zmom(km) = ZFULL(1) is bottom model layer height + ! NB. zm(:,k) = zi(:,k+1) + zmom3(II) = zm(i,k) ! ZFULL(i,k) +!! Heights of the original model layers for the canopy columns are extracted to the zmom array. + + ! Create temperature & humidity array on reversed layer order for interpolation + ta3 (II) = T1 (i,k) ! K + qv3 (II) = Q1 (i,k,1) ! 1=water vapor kg kg-1 + prsl3(II) = PRSL(i,k) ! Pa mean layer pressure + dens3(II) = DENS(i,k) ! kg m-3 + ws3 (II) = sqrt(u1(i,k)**2+v1(i,k)**2) + dkt3 (II) = DKT (i,k) ! m2 s-2 + dku3 (II) = DKU (i,k) ! m2 s-2 + +! From satmedmfvdifq.F: +! MOL = zol(i)/zl(i,k) !Monin-Obukhov Length in layer +! ZL is mid layer height [m] + mol3(II) = zol(i)/ZL(i,k) !Monin-Obukhov Length in layer + end do + + do k = 1, km+1 ! from bottom to top + II = (km + 1) + 1 - k ! from top to bottom of resolved model layers + + prsi3 (II) = PRSI(i,k) ! Pa air pressure at model layer interfaces +! Paul's SIGM does not include surface layer lower interface (1.0) !!! + sigmom3(II) = PRSI(i, k)/ psfc(i) ! PRES_FULL(i, k) / psfc(i) + + end do + +!!! Find the resolved model level which lies above the top of the forest canopy, +!!! in each canopy column. Usually the canopy is within the km or km-1 +!!! level of the original model structure. +! +! The model level above the tallest canopy in grid + kcan_top = 2 ! initialize to 2nd top model layer + do L = km, 3, -1 ! from bottom to top model layer (going up) + ! Mid-layer height m, zmid + if (zmid3(L) > hcan) then ! Paul's zt is our zmid + kcan_top = L - 1 ! level above the tallest canopy + exit + end if + end do +! kcan_top = 62 or 63 +! print*,'canopy_levs: kcan_top = ', i, kcan_top + +! MV2D_ILMO: Aggregated Inverse of Monin-Obukhov length +! Setup of Monin-Obhukov Length similar to plumerise for upper limit: +! from satmedmfvdifq.F: ! MOL = zol(i)/zl(i,k) !Monin-Obukhov Length in layer + safe_inv_mo_length(i) = ilmo(i) + if (abs(ilmo(i)) > THRESHOLD) then + safe_inv_mo_length(i) = sign(THRESHOLD, ilmo(i)) + end if +! +! Adjust the canopy levels: we don't want canopy levels to get closer than del (0.2m) +! to the model levels to prevent possible differencing errors in the diffusion. +! If zcan3 > zmid3 but is too close to zmid3, move zcan3 up by ddel. If zcan3 < zmid3 +! but is too close to zmid3, move zcan3 down by ddel. The net result will be that the +! canopy levels are never closer than del from the original model levels. + do k = kcan_top, km! from model layer above the canopy to bottom of model layer + do kc = 1, nkc ! from top to bottom of canopy + if (abs(zmid3(k) - zcan3(kc)) < del) then + ddel = max(0.0, del - abs(zcan3(kc) - zmid3(k))) + zcan3(kc) = zcan3(kc) + sign(ddel, zcan3(kc) - zmid3(k)) + +!!! The reason why this section is necessary: while it would be preferable for +!!! the canopy levels to stick with values of hc, 0.5 hc and 0.2 hc, somewhere in a +!!! large domain, there may be an overlap where one of these canopy levels is very +!!! close to or on top of an existing model level. Which we dont want! +!!! What is done here, if the canopy levels come within "ddel" of an original model level, +!!! is to shift the canopy level in question a bit, to avoid overlaps. + end if + end do + end do + +!!! Starts the creation of the local array with the heights of the thermodynamic +!!! levels (layer midpoints) for the combined canopy + no canopy layers. +!!! Note that zmid_can at this point does not have these layers sorted in the +!!! correct order - the canopy layers have been tacked onto the bottom of the +!!! zmid_can array, but the values of zmid_can are not monotonically increasing with +!!! decreasing height index. +! +! Set the initial values of the combined height array: +! +! Note that here, zmid_can is created, but the heights within each column have +! yet to be sorted to rearrange the layers in the correct order. + do k = 1, km ! from top to bottom model layers + zmid_can3(i,k) = zmid3(k) + ! Paul's zthrmcan is our zmid_can +! + end do + +! Add zcan3 additional thermo levels into zmid_can array for later sorting + do kc = 1, nkc ! from top to bottom canopy layers + zmid_can3 (i,km+kc) = zcan3(kc) + end do + +! +! Determine locations of canopy and resolved model levels within +! the combined array for the canopy columns: +! +!!! This section sorts the zmid_can array to make sure that the new layers are +!!! all ordered so they monotonically increase with decreasing height. + +! Top canopy layer height (km+1) is higher than the bottom model layer height (km) + if (zmid_can3(i, km) < zmid_can3 (i,km+1)) then +! +! Non-trivial case: the ancillary and original array levels intermingle. +! Sort the combined height array to get the right order of the the heights: +! +! zmid_can is the height locations of the combined array, which needs to be sorted: +! since there are only NKC levels in the canopy, and both zcan3 and z +! decrease monotonically, only nkc+1 passes are needed to sort the combined array: + do npass = 1, nkc+1 + flag_error = .false. + do k = nkt, 2, -1 +! Top canopy layer height (nkt-2) is larger than the bottom model layer height (nkt-3 = km) +! Middle canopy layer height (nkt-1) is larger than the top canopy layer height (nkt-2) +! Bottom canopy layer height (nkt) is larger than the middle canopy layer height (nkt-1) + if (zmid_can3(i, k) > zmid_can3(i, k-1)) then +! The combined array heights are out of order, sort them: + tmp = zmid_can3(i, k-1) + zmid_can3(i, k-1) = zmid_can3(i,k) + zmid_can3(i, k) = tmp + flag_error = .true. + end if + end do + end do + if (flag_error) then + write(errmsg,fmt='(*(a))') 'NKC+1 passes insufficient to sort canopy array ' // & + 'in canopy_levs.F90. Scream and die.' + errflg = 1 + return + end if + end if + +! +! Heights in zmid_can should now be monotonically decreasing. + +! Next, identify the locations of the vertical levels in the combined +! array relative to the resolved model array and canopy array +! +!!! Now that the heights in zmid_can are in the right order, we can use them to +!!! identify the values of kcan and kmod: the vertical locations of the canopy and +!!! original model layers in the augmented canopy layer code. + do kc = 1, nkc ! from top to bottom canopy layers + do kk = nkt, 1, -1 ! from bottom to top of combined canopy and resolved model levels + if (zmid_can3 (i, kk) == zcan3(kc)) then + kcan3(i,kc) = kk + exit + endif + end do + end do + +! k=1 is top model layer +! k=km is bottom model layer + do k = 1, km ! from top to bottom model layers + do kk = k, nkt! from bottom to top of combined resolved plus canopy layers + +! zmid_can3(1) = zmid3(1) is top model layer height +! ... +! zmid_can3(km)= zmid3(km) is bottom model layer height + if (zmid_can3(i, kk) == zmid3(k)) then + +! kmod(1) is 1 , top model layer +! kmod(km-1) is km-1, 2nd model layer +! kmod(km) is top canopy layer (modified after monotonic adj.) + kmod(i,k) = kk + exit + endif + end do + end do + + if (local_dbg) then + do kc = 1, nkc + if (kcan3(i,kc) < 1) then +! write(errmsg,fmt='(*(a,i0,a,i0))') 'canopy_levs: kcan undefined: kc=', kc, & +! ' kcan3=', kcan3(i,kc) + write(errmsg,*) 'canopy_levs: kcan undefined: ', kc, kcan3(i,kc) + errflg = 1 + return + end if + end do + do k = 1,km + if (kmod(i,k) < 1) then +! write(errmsg,fmt='(*(a,i0,a,i0))') 'canopy_levs: kmod undefined: k=', k, & +! ' kmod=', kmod(i,k) + write(errmsg,*) 'cannopy_levs: kmod undefined: ',k, kmod(i,k) + errflg = 1 + return + end if + end do + end if + + +! Create the corresponding momentum height array +! +! The original methodology adopted made use of the at2m array and the thermodynamic heights determined above. +! However, this methodology resulted in momentum levels which did not match the original model levels +! above the region modified for canopy layers. Here, the thermodynamic layers will be used to +! (1) Determine whether the original model and canopy thermodynamic layers coincide, and if so, +! (2) Use the existing model layer values for the momentum layers, while if not, +! (3) Assign the new momentum layers as being 1/2 way between the canopy layers +! Note that these changes only exist inside the chemistry part of GEM-MACH and do not affect the model physics +!!! +!!! Create the momentum height (layer interface) array. The original momentum layers are used above the canopy height. +!!! Below the canopy height, the "momentum" layers are assumed to be ½ way between the thermodynamic layers. + +! Default case: all added canopy thermodynamic layers are below the lowest resolved model thermodynamic layer +! kcan_top is either 2nd or 3rd (63 or 62) resolved model layer + do k = 1, kcan_top - 1 ! from top model layer to model layer above the canopy +! zmom(1) is top model layer height +! zmom(kcan_top-1) is model layer above the canopy < 234.061m + zmom_can3(i,k) = zmom3(k) ! full layer height [m] + end do + + ka(i) =km + inner0: do k = kcan_top, km-1 ! from resolved model layer above the canopy to top model layer +! Starting from the top, scan down through the original and combined mid layer heights, to see when +! they first deviate from each other + !Paul's zthrmcan is our zmid_can + !Paul's zt is our zmid + if (zmid_can3(i,k) == zmid3(k) .and. zmid_can3(i,k+1) == zmid3(k+1)) then + ! Paul's zmom is our zmom + ! Paul's zmomcan(nkt+1) is our zmom_can + zmom_can3(i,k) = zmom3(k) ! full layer height [m] + else + ka(i) = k + exit inner0 + end if + end do inner0 + +! ka is 63 or 64 +! print*,'canopy_levs: ka = ', i, ka(i) + +! ka is the lower-most layer for which the combined layer zmom_can = zmom resolved model layer + ! Paul's zmom is our zmom + ! Paul's zmomcan is our zmom_can + zmom_can3(i,ka(i)) = zmom3(ka(i)) + do k = ka(i)+1, nkt! from ka to bottom combined canopy and resolved layers + zmom_can3(i,k) = (zmid_can3(i,k-1) + zmid_can3(i,k)) * 0.5 + + end do + +!######################################################################## + +! create original model arrays of z and sigma-t which include the surface, to +! allow interpolation: + !Paul's sigtcan is our sigmid_can + sigmid_can(:,:) = 0.0 + do k = 1, km! from top to bottom of resolved model layers + +! zmid3(1) is top model layer height +! zmid3(km) is bottom model layer height + z2(k) = zmid3(k) + +! Fill in the thermodynamic sigma levels (Pre-existing levels first): +! kmod(1) is 1 top (last) model layer +! kmod(km) is 64 bottom (1st) model layer + kk = kmod(i,k) + sigmid_can(i, kk) = sigmid2(k) + + end do + klower_can(:) = -999 + z2(km+1) = 0.0 + +! fill in the remaining sigma levels by interpolating in z: + do kc = 1, nkc ! from top to bottom canopy layers + do k2 = kcan_top, km+1 ! from resolved model layer above the canopy to top model layer + if (zcan3(kc) > z2(k2) .and. zcan3(kc) <= z2(k2-1)) then + +! Interpolate in sigma + sigmid_can(i, kcan3(i,kc)) = sigmid2(k2-1) + & + (sigmid2(k2) - sigmid2(k2-1)) / & + ( z2(k2) - z2(k2-1)) * & + (zcan3(kc) - z2(k2-1)) + +! Store grid locations for use in later interpolations + klower_can(kc) = k2 + end if + + end do + + if (klower_can(kc) < 1) then + errflg = 1 + + write(errmsg,*) 'canopy_levs: klower_can is unassigned at i, kc: ', i, kc + write(errmsg,*) 'canopy_levs: zcan3(kc): ',zcan3(kc) +! + do kk = kcan_top, km+1 + write(errmsg,*) 'canopy_levs: kk z2(kk) which should bracket the above zcan3: ',kk, z2(kk) + end do + do kk = 1, km+1 + write(errmsg,*) 'canopy_levs: kk z2(kk) full set of z2 values: ', kk, z2(kk) + end do + do kk = 1,nkc + write(errmsg,*) 'canopy_levs: kc zcan3(kc) hcan fr(kc) for full set of zcan3 values: ',kk, zcan3(kk), hcan, can_frac(kk) + end do + + return + end if + end do + +! NB. klower_can(1) is 64 or 65 +! klower_can(2) is 65 except for individual grid points near West coast +! klower_can(3) is 65 uniformly +! +! + if (local_dbg) then +! Check on klower_can for NaN or out of bounds: + do kc = 1,nkc + if ((klower_can(kc) /= klower_can(kc)) .or. & + (klower_can(kc) <= 0) .or. & + (klower_can(kc) > km+ 1) ) then +! write(errmsg,*) 'canopy_levs: klower_can after creation NaN or <=0 or >km+1 : ', & +! kc, klower_can(kk) + return + end if + end do + end if +! +! Create sigma coordinate momentum levels: +! +! As above, the existing momentum levels and the canopy values are used to create SIGM levels +! +! (1) Determine whether the original model and canopy thermodynamic layers coincide, and if so, +! (2) Use the existing model layer values for the momentum layers, while if not, +! (3) Assign the new momentum layers as being 1/2 way between the canopy layers +! Note that these changes only exist inside the chemistry part of GEM-MACH and do not affect the +! model physics + + +! Default case: all added canopy half layers are +! below the lowest resolved model half layer + ka(i) = km + inner2: do k = 1, km-1 + if (sigmid_can(i, k) == sigmid2(k) .and. sigmid_can(i, k+1) == sigmid2(k+1) ) then + sigmom_can(i, k) = sigmom3(k) + else + ka(i) = k + exit inner2 + end if + end do inner2 +! ka is the last layer for which sigmom_can= sigmom3(k) + sigmom_can(i, ka(i)) = sigmom3(ka(i)) + do k = ka(i)+1,nkt + sigmom_can(i, k) = (sigmid_can(i, k-1) + sigmid_can(i, k)) * 0.5 + end do + sigmom_can(i, nkt+1) = 1.0 + +! Next, do a sort of all of the variables in the original METV3D array into canopy. Note that +! the declaration of the met arrays for the new canopy subdomain has occurred earlier in the code. +! Three-D variables are a bit more complicated, in that one must make decisions regarding +! the values of the met variables in the canopy region. +! The code which follows is based on chm_load_metvar.ftn90 +! +! First, carry over original model values for the matching layers + do k = 1, km ! from bottom to top of resolved model layers + ! kmod(1) is 1 top model layer + ! kmod(km) is 65 top canopy layer (modified after mono adj.) + kk = kmod(i,k) + ta_can3 (kk) = ta3 (k) ! TA (i, k) ! temperature [K] + qv_can3 (kk) = qv3 (k) ! Met_Data%QV (i, k) ! spec. humidity + prsl_can3(kk) = prsl3(k) ! Met_Data%PRES(i, k) ! Pa + prsi_can3(kk) = prsi3(k) ! + dens_can3(kk) = dens3(k) ! Met_Data%DENS(i, k) ! kg m-3 + ws_can3 (kk) = ws3 (k) ! ! m s-1 + dkt_can3 (kk) = dkt3 (k) ! DKT (i, k) ! m2 s-2 atmos. thermal diffus. + dku_can3 (kk) = dku3 (k) ! DKU (i, k) ! m2 s-2 atmos. momentum diffus. + + end do ! km + +!---------------------------------------------------------------------------- +! Canopy region: next, go through each variable to work out canopy values. +! +! (1) Do those variables for which special canopy formulae will NOT be used: + do kc = 1, nkc ! from top to bottom of canopy layers + +! Each of the following 2 variables have a screen height (2m) value in the 2D met arrays +! Temperature: TA, T2M +! Specific humidity: Q, Q2M + +! kcan3(1) = 65 +! kcan3(2) = 66 +! kcan3(3) = 67 + kk = kcan3(i,kc) + if (klower_can(kc) <= km) then +! Level is above first resolved model level + + k2 = klower_can(kc) + zm2 = (zcan3(kc) - z2(k2-1)) / (z2(k2) - z2(k2-1)) +! zm2 = (zcan3(kc) - z2(k2-1)) / max(z2(k2) - z2(k2-1), epsilon) + + td = ( ta3(k2) - ta3(k2-1)) * zm2 + hd = ( qv3(k2) - qv3(k2-1)) * zm2 + ta_can3(kk) = ta3(k2-1) + td + qv_can3(kk) = qv3(k2-1) + hd + + else +! Level is below first resolved model level + + if (zcan3(kc) - z2(km+1) >= 2.0) then + ! Level is below first resolved model level but above screen height + + zm2 = (zcan3(kc) - z2(km+1) - 2.0) / (z2(km) - z2(km+1) - 2.0) +! zm2 = (zcan3(kc) - z2(km+1) - 2.0) / max(z2(km) - z2(km+1) - 2.0, epsilon) + + td = (ta3(km) - T2M( i ) ) * zm2 + hd = (qv3(km) - Q2M( i ) ) * zm2 + ta_can3(kk) = T2M( i ) + td + qv_can3(kk) = Q2M( i ) + hd + + else + ! Level in canopy is below screen height; assume constant values below screen height + + ta_can3(kk) = T2M( i ) ! 2-m temperature [K] + qv_can3(kk) = Q2M( i ) ! 2-m spec. humidity + end if + + end if + +! Evaluate the air density in canopy columns using values determined above +! +! NB. PRSL is air pressure on ZL, formerly ZH (mid-layers) +! PRSI is air pressure on ZI, formerly ZF (interfaces) +! psfc is surface air pressure psfc + +! get pressure from sigma levels in Pa + prsl_can3(kk) = sigmid_can(i, kk) * psfc(i) ! ~zl mid-layers centers + prsi_can3(kk) = sigmom_can(i, kk) * psfc(i) ! ~zm/zi layers interfaces + +! aqm_methods: dens: buffer(k) = stateIn % prl(c,r,l) / ( rdgas * stateIn % temp(c,r,l) ) + ! (1) is top model layer + ! ... + ! (km) is 1hy model layer + ! (km+1) is top canopy layer + ! (nkt) is 1st canopy layer + dens_can3(kk) = prsl_can3(kk) / ( RDGAS * ta_can3(kk)) ! kg m-3 + + +! The following variables are assumed to have uniform values throughout the +! lowest resolved model layer: +! +! Cloud liquid water mass mixing ratio (QCPLUS) +! Total cloud fraction (FTOT) +! Stratospheric cloud fraction (FXP) +! Convective cloud fraction (FDC) +! Total liquid water flux (RNFLX) +! Total solid water flux (SNOFLX) +! Precipitation evaporation (FEVP) +! Cloud to rain collection tendency (PPRO) +! Search over the original model layers (k). Note that the outer loop above this +! one is over the canopy layers kc: we are looking for the values to assign the +! canopy layers in the combined canopy+resolved scale space. For these variables, +! the resolved scale values will be used, hence the aim is to determine the +! resolved scale layer in which the canopy layer resides, and assign the +! corresponding values to the locations of the canopy layers in the combined +! canopy + resolved scale space (kk). + + + end do ! kc = 1,nkc +! Surface layer lower interface + prsi_can3(nkt+1) = prsi3(km+1) + + if (local_dbg) then +! Several checks for suspicious values: + do kk = 1,nkt + if ( ta_can3(kk) < 150.0) then + write(errmsg,*) 'canopy_levs: suspicious temperature detected in canopy_levs after creation (kk value): ',& + i, kk, ta_can3(kk) + errflg = 1 + + do kc = 1, nkc + write(errmsg,*) 'canopy_levs: value of zcan(kc) z2(km+1) and difference at this value of ic for kk: ',& + kc,' are: ',zcan3(kc),z2(km+1), zcan3(kc)-z2(km+1) + end do + + do k = 1, nkt + write(errmsg,*) 'canopy_levs: value of zmid_can for = ', i,' at k = ',k,' is: ',zmid_can3(i,k) + end do + + do kc = 1,nkc + write(errmsg,*) 'canopy_levs: values of kcan zcan and original zcan for = ', i,' at kc = ',kc,' are: ',& + kcan3(i,kc), zcan3(kc), hcan * can_frac(kc) + end do + + do k = 1,km + write(errmsg,*) 'canopy_levs: value of kmod and z for = ', i,' at k = ',k,' are: ',kmod(i,k), zmid3(k) + end do + + do kc = 1,nkc + write(errmsg,*) 'canopy_levs: value of klower_can at this grid point for kc: ',kc,' is: ',klower_can(kc) + end do + + return + end if + end do + end if + +! (2) For the last few variables, the value at the lowest resolved model layer and typical profiles for that variable +! within the canopy will be used to create the canopy values: + do kc = 1, nkc + kk = kcan3(i,kc) +! Ratio of lowest model level to canopy height: +! + zr = (zmid3(km) - z2(km+1)) / hcan +! +! Horizontal wind and KT profiles are from Raupach, Quarterly Journal +! of the Royal Meteorological Society, vol 115, pp 609-632, 1989, examples +! from page 626, equations (48) through (51). +! +! Wind speed (equation 51), assumed to scale similarly in each horizontal dimension: +! +! U(z) = ustar/karman * ln((z - d) / z0), where +! k = 0.4 +! d = 0.75 hc +! z0 = 0.07530 hc +! The next few lines calculate the average value of u(z), v(z), Raupach's eqn 51, +! at the first resolved level model height +! Paul's UE is our ustar, surface friction velocity + uh = ustar(i) * 3.0 + if (zr >= 1.0) then + ! Paul's zt is our zmid (i.e. zmid(km) is zt(i,chm_nk)) + ! Paul's hc is our hcan + uspr = ustar(i) / karman * & + log((zmid3(km) - z2(km+1) - 0.75 * hcan) / & + (0.07530 * hcan)) +! log(max((zmid3(km) - z2(km+1) - 0.75 * hcan) / & +! (0.07530 * hcan), epsilon)) + else + uspr = uh * exp(- 2.0 * ( 1.0 - zr)) + end if +! wndr is the ratio of the wind to Raupach's average us(), eqn 51. +! This is used to scale the wind speed with height values from eqn 51 to the current grid square + ! Paul's WS(nk) is our spd1, wind speed at lowest model level m s-1 + wndr = spd1(i) / uspr +! wndr = spd1(i) / max(uspr, epsilon) +! Using Raupach's formulae for wind speed, multiplied by the above ratio, for the canopy layers: +! + zr = (zcan3(kc) - z2(km+1)) / hcan + if (zr >= 1.0) then + uspr = log((zcan3(kc) - z2(km+1) - 0.75 * hcan) / & + (0.07530 * hcan)) * ustar(i) + else + uspr = uh * exp(- 2.0 * (1.0 - (zcan3(kc) - z2(km+1)) / hcan)) + end if + + ws_can3(kk) = wndr * uspr +! +! Coefficients of diffusivity: +! Find value of K at first model level from raupach's sigw and TL formulae (eqns 48, 49) + zr = (zmid3(km) - z2(km+1)) / hcan +! Gradient in stability under the canopy is reduced for higher stability conditions +! in accord with Shaw, den Hartog and Neumann, BLM 45, 391-409, 1988, Fig 16. + ! Paul's zl is our hol (as in satmedmfvdifq.F) + hol = hcan * safe_inv_mo_length(i) +! Unstable: + if(hol < -0.1) then + a1 = 0.75 + b1 = 0.5 + c1 = 1.25 + end if +! Neutral: + if(hol >= -0.1 .and. hol < 0.1) then + a1 = 0.625 + b1 = 0.375 + c1 = 1.0 + end if +! Stable: + if(hol >= 0.1 .and. hol < 0.9) then + rat = 4.375 - 3.75 * hol + a1 = 0.125 * rat + 0.125 + b1 = 0.125 * rat - 0.125 + c1 = 0.25 * rat + end if +! Very stable (from extrapolation of Shaw et al's values at 0.1 and 0.5: + ! Paul's MV3D_KT(nk) is our dkt3(km) m2 s-1 atmospheric heat diffusivity (thermal vertical diffusion coefficient) + ! 1st (bottom) model layer + if(hol >= 0.9 .or. dkt3(km) <= min_kt) then + a1 = 0.25 + b1 = 0.0 + c1 = 0.25 + end if +! Raupach's originals: +! if (zr >= 1.0) then +! sigw = ustar(i) * 1.25 +! else +! sigw = ustar(i) * ( 0.75 + 0.5 * cos(pi * (1.0 - (zmid3(km) - z2(km+1))/hcan) ) ) +! end if +! Replace Raupach's originals with fit to Patton et al and Shaw et al 1988 + if(zr < 0.175) then + sigw = ustar(i) * 0.25 + else + if(zr < 1.25) then + sigw = ustar(i) * ( a1 + b1 * cos(pi / 1.06818 * & + (1.25 - (zmid3(km) - z2(km+1)) / hcan))) + else + sigw = ustar(i) * c1 + end if + end if + +! tl = hcan / max(ustar(i), epsilon) * & + tl = hcan / ustar(i) * & + (0.256 * ((zmid3(km) - z2(km+1) - 0.75 * hcan) / hcan) + & + 0.492 * exp (-(0.256 * ((zmid3(km) - z2(km+1)) / hcan) / 0.492))) +! ktr is the ratio of the resolved model diffusivity at the lowest resolved +! model level to that derived by Raupach's formula +! + ktr = dkt3(km) / (sigw * sigw * tl) + kur = dku3(km) / (sigw * sigw * tl) +! ktr = dkt3(km) / max(sigw * sigw * tl, epsilon) +! kur = dku3(km) / max(sigw * sigw * tl, epsilon) + +! print*, 'canopy_levs: KTR= ', i, ktr, dkt3(km), kk, kc +! +! Use Raupach's formulae for diffusivity, multiplied by the above ratio, for the canopy layers: +! + zr = (zcan3(kc) - z2(km+1)) / hcan +! Gradient in stability under the canopy is reduced for higher stability conditions +! in accord with Shaw, den Hartog and Neumann, BLM 45, 391-409, 1988, Fig 16. +! Raupach's original: +! if (zr >= 1.0) then +! sigw = ustar(i) * 1.25 +! else +! sigw = ustar(i) * ( 0.75 + 0.5 * cos(pi * (1.0 - (zcan3(kc) - z2(km+1))/hcan) ) ) +! end if + if(zr < 0.175) then + sigw = ustar(i) * 0.25 + else + if(zr < 1.25) then + sigw = ustar(i) * ( a1 + b1 * cos(pi / 1.06818 * & + (1.25 - (zcan3(kc) - z2(km+1))/hcan))) + else + sigw = ustar(i) * c1 + end if + end if +! +! tl = hcan / max(ustar(i), epsilon) * & + tl = hcan / ustar(i) * & + (0.256 * ( (zcan3(kc) - z2(km+1) - 0.75 * hcan) / hcan) + & + (0.492 * exp (-(0.256 * (zcan3(kc) - z2(km+1)) / hcan) / 0.492) ) ) + + dkt_can3(kk) = (sigw * sigw * tl) * ktr + dku_can3(kk) = (sigw * sigw * tl) * kur + +! print*, 'canopy_levs: DKT_CAN= ', i, sigw, tl, dkt_can3(kk), kk, kc + end do ! kc = 1,nkc +! + if (local_dbg) then + do kc = 1, nkc + if (kcan3(i, kc) == 0) then + write(errmsg,fmt='(*(a,i0,a,i0))') 'kcan zero inside canopy_levs at i=', i, ' kc=', kc + errflg = 1 + return + end if + end do + end if +! + do k = 1, nkt! from top to bottom of combined layers + II = nkt + 1 - k ! from bottom to top of combined layer + + ! Flip back meteo arrays on combined layers in same layer order as original model layer + ! nkt is top model layer <= 1 + ! ... + ! (4) is 1st (bottom) model layer <= km + ! (3) is 3rd (top) canopy layer <= nkt-2 + ! (2) is 2nd canopy layer <= nkt-1 + ! (1) is 1st (bottom) canopy layer <=nkt + ZL_CAN (i,II) = zmid_can3(i, k) + ZM_CAN (i,II) = zmom_can3(i, k) + PRSL_CAN(i,II) = prsl_can3(k) + + T1_CAN (i,II) = ta_can3 (k) + QV_CAN (i,II) = qv_can3 (k) + DENS_CAN(i,II) = dens_can3(k) + WS_CAN (i,II) = ws_can3 (k) + DKT_CAN (i,II) = dkt_can3 (k) + DKU_CAN (i,II) = dku_can3 (k) + + end do ! k = 1, nkt + +! Pressure at layers interfaces + do k = 1, nkt+1 ! from top to bottom of combined layers + II = (nkt+1) + 1 - k ! from bottom to top of combined layer + +! (km+1) (68=nkc+km +1) prsi3( 1) Top model layer upper interface prsi_can3(1) +! (km) (67=nkc+km ) prsi3( 2) +! ... +! (2) (5 =nkc +2) prsi3(km) Bottom model layer upper interface prsi_can3(km) +! (4 =nkc +1) Top canopy layer upper interface prsi_can3(km+1) +! (3) Mid canopy layer upper interface +! (2) Bottom canopy layer upper interface prsi_can3(nkt) +! (1) (1) prsi3(km+1) Bottom model layer LOWER interface prsi_can3(nkt+1) +! + PRSI_CAN(i,II) = prsi_can3(k) + + end do ! k = 1, nkt+1 + + + END IF ! Continuous forest canopy: FRT_MASK == 1. + +! ... have not finished Paul's code ... + + + END DO !I-index + + end subroutine canopy_levs_run + + end module canopy_levs_mod diff --git a/physics/PBL/SATMEDMF/canopy_mask.F90 b/physics/PBL/SATMEDMF/canopy_mask.F90 new file mode 100644 index 000000000..0f31daf0f --- /dev/null +++ b/physics/PBL/SATMEDMF/canopy_mask.F90 @@ -0,0 +1,101 @@ + module canopy_mask_mod + + use machine , only : kind_phys + + implicit none + + public :: canopy_mask_init, canopy_mask_run + + contains + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + subroutine canopy_mask_init(im, km, nkc, nkt, & + claie, cfch, cfrt, cclu, cpopu, & !in: + FRT_mask, & ! out + errmsg,errflg) + + implicit none + +! Horizontal arrays + integer :: im, km ! horizontal & vertical domain specifications + integer, intent(in) :: nkc, nkt + + real(kind=kind_phys) :: claie(im), cfch(im), cfrt(im), & + cclu(im),cpopu(im) + real(kind=kind_phys) :: FRT_mask(im) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!...local variables + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!...Allocate and initialize new canopy arrays + +! Initializations + + FRT_mask(:)=0.0 + + return + end subroutine canopy_mask_init + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + + subroutine canopy_mask_run (im, km, nkc, nkt, & !in: + claie, cfch, cfrt, cclu, cpopu, & !in: + FRT_mask, & !out: + errmsg,errflg) + + implicit none + +!...Arguments: + +! Horizontal arrays + integer :: im, km ! horizontal & vertical domain specifications + integer, intent(in) :: nkc, nkt + + real(kind=kind_phys) :: claie(im), cfch(im), cfrt(im), & + cclu(im), cpopu(im) + real(kind=kind_phys) :: FRT_mask(im) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!...local variables + + integer i + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + + !NOT a Continuous forest canopy + if ( claie(i) .LT. 0.1 & + .OR. cfch (i) .LT. 0.5 & +!IVAI: modified contiguous canopy condition +! .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.5 + .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.75 & + .OR. cpopu(i) .GT. 10000.0 & + .OR. (EXP(-0.5*claie(i)*cclu(i)) .GT. 0.45 & + .AND. cfch(i) .LT. 18.) ) THEN + + FRT_mask(i) = -1.0 + + ! Continuous forest canopy + ELSE + + FRT_mask(i) = 1.0 + + END IF ! Forest Canopy Mask + + end do + + return + end subroutine canopy_mask_run + + end module canopy_mask_mod diff --git a/physics/PBL/SATMEDMF/canopy_transfer.F90 b/physics/PBL/SATMEDMF/canopy_transfer.F90 new file mode 100644 index 000000000..b32d41198 --- /dev/null +++ b/physics/PBL/SATMEDMF/canopy_transfer.F90 @@ -0,0 +1,786 @@ + module canopy_transfer_mod + contains + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + subroutine canopy_transfer_init( im, km, nkc, nkt, & !in + massair_can, massair, & !out + mmr_o3_can, & !inout + nfrct, ifrct, & !out + frctr2c, frctc2r, & !out + errmsg, errflg ) + +! Input/Output variables, original Horizontal coordinate +! +! Local variables: +! massair_can(:,nkt) : mass of air in canopy layers (kg) +! massair (:, km) : mass of air in model layers (kg) +! (gathered canopy + resolved scale columns) +! nfrct (nkt, :) : Number of original model levels contributing to canopy level k +! ifrct (nkt, 2,:) : Index of the original model level contributing to canopy level k +! frctr2c(nkt, 2,:) : Fractional contribution of the original model level to canopy level k +! frctc2r(nkt, 2,:) : Fractional contribution of the canopy level to the original model level +! +!============================================================================= + + use machine , only : kind_phys + + IMPLICIT NONE + +!...Arguments: + + integer, intent(in) :: im, km, nkc, nkt + + integer, intent(out) :: & + nfrct (km+nkc, im) , & + ifrct (km+nkc, 2, im) + + real(kind=kind_phys), intent(out) :: & + massair_can(im, km+nkc) , & + massair (im, km) , & + mmr_o3_can (im, km+nkc) , & + frctr2c (km+nkc, 2, im) , & + frctc2r (km+nkc, 2, im) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!...local variables + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + massair_can(:,:) = 0. + massair (:,:) = 0. + mmr_o3_can (:,:) = 0. + + nfrct (:,:) = 0 + ifrct (:,:,:) = 0 + frctr2c(:,:,:) = 1. + frctc2r(:,:,:) = 1. + + return + end subroutine canopy_transfer_init + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + + subroutine canopy_transfer_run( im, km, nkc, nkt, & + ntrac, ntoz, & + GAREA, & + zi, zl, zm, & + Q1, DENS, & !in: kg kg-1 + FLAG, & !in + FRT_MASK, & !in + kmod, kcan3, & !in + zmom_can, zmid_can, & !in + PRES_CAN, DENS_CAN, & !in + Q1_MOD, Q1_CAN, Q1_2M, & !inout kg kg-1 + massair_can, massair, & !inout + mmr_o3_can, & !inout + nfrct, ifrct, & !inout + frctr2c, frctc2r, & !inout + errmsg, errflg ) + +! Arguments: +! Input variables +!----------------------------------------------------------------------------- +! Array dimensions: +! nkc : number of canopy levels +! nkt= km + nkc : number of levels in gathered canopy + resolved scale columns +! met???_CAN(:.:, nkt): : met 3d variables, gathered canopy + resolved scale columns +! kmod(km) : Vertical index location of original ungathered model layer in combined +! canopy + resolved scale column +! flag : 0 -> resolved_to_canopy +! 1 -> canopy_to_resolved +! +! Input/Output variables, original Horizontal coordinate +! Q1_CAN(:,nkt, NSPCSD) : Chemical tracers concentrations kg kg-1 combined canopy and resolved model layers +! Q1_MOD(:,km, NSPCSD) : Chemical tracers concentrations kg kg-1 on model levels (copy of CONC) +! Q1 (:,km, NSPCSD) : Chemical tracers concentrations kg kg-1 on model levels +! Q1_2M (:, NSPCSD) +! +! Local variables: +! massair_can(:, nkt) : mass of air in canopy layers (kg) +! massair (:, km) : mass of air in model layers (kg) +! (gathered canopy + resolved scale columns) +! nfrct (nkt, :) : Number of original model levels contributing to canopy level k +! ifrct (nkt,2,:) : Index of the original model level contributing to canopy level k +! frctr2c(nkt,2,:) : Fractional contribution of the original model level to canopy level k +! frctc2r(nkt,2,:) : Fractional contribution of the canopy level to the original model level +! +!============================================================================= + + use machine , only : kind_phys + + IMPLICIT NONE + +!...Arguments: + + integer, intent(in) :: im, km, nkc, nkt, ntrac, ntoz + integer, intent(in) :: flag + real(kind=kind_phys), intent(in) :: zi(im, km+1), zl(im, km), zm(im, km) + real(kind=kind_phys), intent(in) :: GAREA(im) + +! ** Q1 is concentration field (including gas and aerosol variables) mass mixing ratio kg kg-1 + real(kind=kind_phys), intent(in) :: Q1(im, km, ntrac) + + real(kind=kind_phys), intent(in) :: DENS(im, km) + + integer, intent(in) :: kmod (im, km), kcan3 (im, nkc) + + real(kind=kind_phys), intent(inout) :: zmom_can (im, nkt) , & + zmid_can (im, nkt) + + real(kind=kind_phys), intent(in) :: FRT_MASK (im) , & +! met3d arrays + PRES_CAN (im, nkt) , & + DENS_CAN (im, nkt) + +! all gas-phase species array + real(kind=kind_phys), intent(inout) :: Q1_MOD (im, km, ntrac), & + Q1_CAN (im, nkt, ntrac) + real(kind=kind_phys), intent(inout) :: Q1_2M (im, ntrac) + + integer, intent(inout) :: nfrct (km+nkc, im) , & + ifrct (km+nkc, 2, im) + + real(kind=kind_phys), intent(inout) :: massair_can(im, km+nkc), & + massair (im, km) , & + mmr_o3_can (im, km+nkc), & + frctr2c (km+nkc, 2, im), & + frctc2r (km+nkc, 2, im) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!...Local arrays: + + real(kind=kind_phys) :: zmid (km) , & + zmom (km+1), & ! Same as zfull ! + z2 (km+1), & + sigmid2 (km+1), & + zcan3 (nkc) ,& + pres_can3 (nkt), pres3 (km) , & + dens_can3 (nkt), dens3 (km) , & + klower_can(nkc) , & + dxdy (im) + + real(kind=kind_phys) :: & + mass_canopy (nkt), & + mmr_canopy (nkt), & + vmr_canopy (nkt), & + mmr_resolved (km + 1), & + vmr_resolved (km + 1), & + mass_resolved(km), & + conc3 (km), & + conc_can3 (nkc) + +!...local variables + + INTEGER :: i, S, IS + + INTEGER :: LEV, L + + INTEGER :: KOUNT + +! Diagnostic height is the assumed height above ground of the sampling for observations + real(kind=kind_phys), parameter :: diag_hgt = 2.0 + real(kind=kind_phys), parameter :: epsilon = 1.e-10 + +!-------------- +!hrinit.F: ...set scale factor for [ppm] -> [kg/kg] +! +! CGRID to CHEM Species conversion factor +! FORWARD_CONV( N ) = 1.0E-3 * MWAIR / SPECIES_MOLWT( N ) ! ug kg-1 to ppm +! CHEM to CGRID Species conversion factor +! REVERSE_CONV( N ) = 1.0E+3 / MWAIR * SPECIES_MOLWT( N ) ! ppm to ug kg-1 +!-------------- +! Conversion factor from units in [kg kg-1] to [ug kg-1] + REAL(kind=kind_phys), PARAMETER :: FORWARD_CONV = 1.E-9 ! ug kg-1 -> kg kg-1 + REAL(kind=kind_phys), PARAMETER :: REVERSE_CONV = 1.E+9 ! kg kg-1 -> ug kg-1 + + real(kind=kind_phys) :: mmr_diag + + logical(kind=4) :: chm_error_l = .false. + + integer(kind=4) :: k, kk, kc, k2, II, npass + + logical(kind=4) :: local_dbg + local_dbg = .true. + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + conc_can3(:)=0. + conc3 (:)=0. + mass_canopy(:) = 0. + mmr_canopy (:) = 0. + vmr_canopy (:) = 0. + mmr_resolved(:) = 0. + vmr_resolved(:) = 0. + mass_resolved(:) = 0. + +! RELWTEM( ICG ) = CONVMW / NR_MOLWT( SP_INDX ) + + DO i = 1, im !i-index + +!!! Non-Canopy columns + IF (FRT_mask(i) <= 0.) THEN + +!!!!! Start all columns!!!!! canopy & non-canopy (canopy columns are overwritten below) + do k = 1, km ! from bottom to top + II = km + 1 - k ! from top to bottom of resolved model layers km+1 ??? +!!! Paul's zmom is our zmom +! zmom(1) = ZFULL(km) is top model layer height +! zmom(km) = ZFULL(1) is bottom model layer height + zmom (II) = zm(i,k) ! ZFULL(i,k) + dens3(II) = DENS(i,k) ! kg/m**3 +!! Heights of the original model layers for the canopy columns are extracted to the zmom array. + + end do + +! Calculate mass of air in model levels + !Paul's zmom is our zmom + zmom(km + 1) = 0.0 + do k = km, 1, -1 + ! Paul's massairmod is our massair + massair(i, k) = dens3(k) * GAREA (i) * & + (zmom(k) - zmom(k + 1)) + end do + +! First, carry over original model values for the matching layers + do k = 1, km ! from bottom to top of resolved model layers + massair_can(i, k) = massair(i, k) ! full layer height [m] + end do + + do kc = 1, nkc ! from top to bottom of canopy layers + massair_can(i, km+kc) = massair(i, km) + end do ! kc = 1, nkc +!!!!! Non-Canopy columns !!!!! + +!!!! Continuous forest canopy + ELSE IF (FRT_mask(i) > 0.) THEN + +! Put vars on combined layers in layer order as in Paul's code (GEM-MACH) +! 1 <= nkt is top model layer +! ... +! km<= (4) is 1st (bottom) model layer +! nkt-2 <= (3) is 3rd (top) canopy layer +! nkt-1 <= (2) is 2nd canopy layer +! nkt <= (1) is 1st (bottom) canopy layer + + do k = 1, nkt + II = nkt + 1 - k + pres_can3(II) = PRES_CAN(i,k) + dens_can3(II) = DENS_CAN(i,k) ! kg/m**3 + end do + +! Calculate mass of air on combined levels + !Paul's zmomcan is our zmom_can(im, nkt+ 1) + ! Layers in reverse order! + ! zmom_can(:,:,1) is top resolved layer + ! zmom_can(:,:,km) is 1hy resolved layer + ! zmom_can(:,:,nkt) is 1st canopy layer + zmom_can(i, nkt+ 1) = 0.0 + do k = nkt, 1, -1 + ! Paul's massaircan is our massair_can + massair_can(i, k) = dens_can3(k) * GAREA (i) * & + (zmom_can(i, k) - zmom_can(i, k + 1)) + end do + + do k = 1, km ! from bottom to top + II = km + 1 - k ! from top to bottom of resolved model layers km+1 ??? +!!! Paul's zmom is our zmom +! zmom(1) = ZFULL(km) is top model layer height +! zmom(km) = ZFULL(1) is bottom model layer height + zmom (II) = zm(i,k) ! ZFULL(i,k) + dens3(II) = DENS(i,k) ! kg/m**3 +!! Heights of the original model layers for the canopy columns are extracted to the zmom array. + end do + +! Calculate mass of air in model levels + !Paul's zmom is our zmom + zmom(km + 1) = 0.0 + do k = km, 1, -1 + ! Paul's massairmod is our massair + massair(i, k) = dens3(k) * GAREA (i) * & + (zmom(k) - zmom(k + 1)) + end do + +! Next, we need a set of arrays which track mass transfer from resolved to model layers; +! how much of the original (aka "resolved") model layer mass goes into each canopy layer, +! given the above level structure. The three arrays are: +! nfrct(k, :) : the number of resolved model levels contributing to canopy level k +! ifrct(k,n,:) : the index of the resolved model level contributing to canopy level k (n is at most 2) +! frctr2c(k,n,:) : the fractional contribution of the resolved model level to canopy level k +! frctc2r(k,n,:) : the fractional contribution of the canopy model level to the resolved model level +! +! Check for coincident layers first: +! + inner: do k = 1, km +! If the following IF statement is true, then the canopy and resolved +! model layer upper and lower boundaries coincide, and the entire resolved model +! model layer contributes to the combined model layer (trivial case). + if (zmom_can(i, k) == zmom(k) .and. zmom_can(i, k+1) == zmom(k+1)) then + nfrct(k, i) = 1 + ifrct(k, 1, i) = k + frctr2c(k, 1, i) = 1.0 + frctc2r(k, 1, i) = 1.0 + else + exit inner + end if + end do inner +! +! "k" is the first layer where boundary levels do not match on output from the above loops. +! Determine fractions of original model layer structure contributing to canopy model layers. + k2 = k + do k = k2, nkt + do kk = k2, km +! (1) Upper boundaries of combined and resolved model layers coincide, +! lower boundary of combined layer is within resolved layer, so canopy +! layer resides entirely within resolved layer, and shares an upper boundary +! with the resolved layer: + if ((zmom_can(i, k) == zmom(kk) .and. zmom_can(i, k+1) > zmom(kk+1)) .or. & +! (2) Lower boundaries coincide, upper boundary of combined layer is within resolved layer, +! so canopy layer resides entirely within the resolved layer, and shares a lower boundary +! with the canopy layer. + (zmom_can(i, k+1) == zmom(kk+1) .and. zmom_can(i, k) > zmom(kk)) .or. & +! (3) Both canopy layer boundaries exist inside a resolved layer, with no shared boundaries: +! nfrct(km + 1) = 1 +! ifrct(km + 1) = 64 + (zmom_can(i, k) < zmom(kk) .and. zmom_can(i, k+1) >= zmom(kk+1))) then + nfrct(k, i) = 1 + ifrct(k, 1, i) = kk +! frctr2c(k, 1, i) = (zmom_can(i, k) - zmom_can(i, k+1)) / max(zmom(kk) - zmom(kk+1), epsilon) + frctr2c(k, 1, i) = (zmom_can(i, k) - zmom_can(i, k+1)) / (zmom(kk) - zmom(kk+1)) + frctc2r(k, 1, i) = 1.0 ! canopy layer resides within resolved model layer + end if +! Resolved layer boundary splits a combined canopy layer: +! This case arises if, due to the use of the momentum levels in the canopy column +! sometimes being half-way between the thermodynamic levels, a resolved model +! momentum layer falls within the canopy layer. Since the resolved model layers are +! defacto thicker than the canopy layers, this means that there can at most be two +! resolved model layers contributing to the canopy layer (only case where nfrct = 2). + if (zmom_can(i, k+1) < zmom(kk) .and. zmom_can(i, k) > zmom(kk)) then + nfrct(k, i) = 2 + ifrct(k, 1, i) = kk + ifrct(k, 2, i) = kk-1 +! Fraction of resolved model layer contributing to canopy layer: +! frctr2c(k, 1, i) = (zmom(kk) - zmom_can(i, k+1)) / max(zmom(kk) - zmom(kk+1), epsilon) +! frctr2c(k, 2, i) = (zmom_can(i, k) - zmom(kk)) / max(zmom(kk-1) - zmom(kk), epsilon) + frctr2c(k, 1, i) = (zmom(kk) - zmom_can(i, k+1)) / (zmom(kk) - zmom(kk+1)) + frctr2c(k, 2, i) = (zmom_can(i, k) - zmom(kk)) / (zmom(kk-1) - zmom(kk) ) +! Fraction of canopy layer contributing to resolved model layer: +! frctc2r(k, 1, i) = (zmom(kk) - zmom_can(i, k+1)) / max(zmom_can(i, k) - zmom_can(i, k+1), epsilon) +! frctc2r(k, 2, i) = (zmom_can(i, k) - zmom(kk)) / max(zmom_can(i, k) - zmom_can(i, k+1), epsilon) + frctc2r(k, 1, i) = (zmom(kk) - zmom_can(i, k+1)) / (zmom_can(i, k) - zmom_can(i, k+1)) + frctc2r(k, 2, i) = (zmom_can(i, k) - zmom(kk)) / (zmom_can(i, k) - zmom_can(i, k+1) ) + end if + end do + end do + +! +! massair_can thus contains the mass of air in the canopy layers in kg, while massair contains the +! mass of air in the original model layers, at the canopy columns (i) +! + END IF ! Continuous forest canopy: FRT_MASK == 1. + + + END DO !i = 1, im !I-index + + +! return tracers to resolved scale model layers: + + if (flag == 1) then ! "canopy_to_resolved" + +! At this point, the model mass is distributed over the combined layers, +! and the tracer concentration arrays are both in the combined layer system. +! + DO i = 1, im !I-index + + KOUNT = 0 + + ! loop over canopy columns + IF (FRT_mask(i) > 0.) THEN + +! Q1_MOD/Q1_CAN: +! Assigned/Initilized in canopy_levs FIRSTIME + +!...fetch all species in units kg kg-1 mass mixing ratio + do S = 1, ntrac-1 ! ntrac1= 197 (ntrac=ntke=198) + +! Flip resolved layer arrays into a new array for use here + do k = 1, km ! from bottom to top + II = km + 1 - k ! from top to bottom of resolved model layers + ! conc3(1) is top model layer + ! conc3(km) is 1st (bottom) model layer + ! Paul's chem_tr is our conc3 = vmr_resolved +! NB. mfpbltq_mod: q1(ix,km,ntrac1) kg kg-1 + ! Paul's chem_tr is our vmr_resolved =conc3 + vmr_resolved(II) = Q1_MOD(i, k, S) ! kg kg-1 + end do + +! Flip combined layer arrays into a new array for use here + do k = 1, nkt ! from top to bottom + II = nkt + 1 - k ! from bottom to top of resolved model layers + ! Paul's trppm is our vmr_canopy (conc_can) + ! (km) is top model layer + ! (1) is 1hy model layer + vmr_canopy(II) = Q1_CAN(i, k, S) !kg kg-1 + end do + +! (ii): Canopy shaded layers + do kc = 1, nkc + k = kcan3(i, kc) ! kcan3(1,2,3) = 65,66,67 + + ! Paul's tracers_can is our conc_can3 array + conc_can3 (kc) = vmr_canopy(k) ! kg kg-1 + end do + +! (1) We start off by converting these mass mixing ratio [kg kg-1] to mass in [ug]: + + do k = 1, km + ! kmod(1) is 1 top model layer + ! kmod(km) is 65 top canopy layer (modified after mono adj.) + kk = kmod(i, k) + +! ...fetch gas mass mix. ratios [kg kg-1] and convert to [ug kg-1] + ! Paul's conc is our mmr_canopy + !mmr_canopy(kk) = REVERSE_CONV * conc3(k) ! ug kg-1 + mmr_canopy(kk) = REVERSE_CONV * vmr_resolved(k) ! ug kg-1 + end do + + do k = 1, nkc + ! kcan3(k=1,2,3) = 65,66,67 + kc = kcan3(i, k) + +! ...fetch gas mass mix. ratios [kg kg-1] and convert to [ug kg-1] + mmr_canopy(kc) = REVERSE_CONV * conc_can3(k) ! ug kg-1 + end do + +! (2) Array "mass_canopy" now holds the mass of the tracer in each of the combined levels. +! This mass must be added back to the resolved levels: + ! Paul's masscan is our mass_canopy + ! Paul's mass_resolved is our mass_resolved + mass_resolved(:) = 0. + do k = 1, nkt + +! Output diag + if(S == 11) mmr_o3_can(i,k) = mmr_canopy(k) ! nto3=11 "canopy_to_resolved" + + mass_canopy(k) = mmr_canopy(k) * massair_can(i, k) ! ug + do kk = 1, nfrct(k, i) + kc = ifrct(k, kk, i) + mass_resolved(kc) = mass_resolved(kc) + mass_canopy(k) * frctc2r(k,kk,i) ! ug + end do + end do + +! +! Check: total mass in the column should be the same + if (local_dbg) then + call canopy_mass_check(mass_canopy, mass_resolved, i, flag, nkc, nkt, errmsg, errflg) + if (errflg /= 0) return + end if +! +! (3) The masses in [ug] need to be converted back to [kg kg-1] + do k = 1, km +! + ! Paul's massairmod is our massair + ! Paul's mass_resolved is our mass_resolved +! mmr_resolved(k) = mass_resolved(k) / max(massair(i, k), epsilon) ! ug kg-1 + mmr_resolved(k) = mass_resolved(k) / (massair(i, k)) ! ug kg-1 + +! (3a) Convert back m.m.r. [ug kg-1] to [kg kg-1] + ! NB. This is Q1_MOD to be used in gas-phase hrdriver call on canopy columns + ! Paul's chem_tr is our conc3 = vmr_resolved + vmr_resolved(k) = FORWARD_CONV * mmr_resolved(k) ! kg kg-1 + + end do + + do k = 1, km ! from bottom to top + II = km + 1 - k ! from top to bottom of resolved model layers + ! zmid(1) = ZM(km) is top model layer height + ! zmid(km) = ZM(1) is bottom model layer height + ! Paul's zt (or ZPLUS) is our zmid + zmid(II) = ZL(i,k) ! mid layer height [m] +!!! Heights of the original model layers for the canopy columns are extracted to the zmid array. + end do + +! +! (4) Evaluate the diagnostic level concentration +! Find the bounding layers above and below the diagnostic height: +! kk'th layer is the layer above the inlet height + kk = nkt + do k = nkt, nkt-8, -1 + ! Paul's zt (MV3D_ZPLUS) is our zmid + if (diag_hgt <= zmid(k-1) .and. & + diag_hgt > zmid(k)) then + kk = k - 1 + end if + end do +! If the diagnostic height is less than the lowest level, then use that level +! for the concentration. + if (kk == nkt) then + mmr_diag = mmr_canopy(nkt) ! ug kg-1 + vmr_resolved (km + 1) = FORWARD_CONV * mmr_canopy(nkt) ! kg kg-1 + + else +! Diagnostic height 2m is always above the lowest model hybrid level ~42m +! The lines below never executed + mmr_diag = & + mmr_canopy(kk) + & + (mmr_canopy(kk) - mmr_canopy(kk + 1)) / & +! max(zmid(kk) - zmid(kk + 1), epsilon) * & + (zmid(kk) - zmid(kk + 1)) * & + (diag_hgt - zmid(kk + 1)) ! ug kg-1 + vmr_resolved (km + 1) = FORWARD_CONV * mmr_diag ! kg kg-1 + + end if + +! Flip back resolved layers arrays for gas-phase integration (hrdriver) + do k = 1, km ! from top to bottom + II = km + 1 - k ! from bottom to top of resolved model layers + ! Paul's trppm is our conc_can (vmr_canopy) + ! (km) is top model layer + ! (1) is 1hy model layer + Q1_MOD(i, II, S) = vmr_resolved(k) ! kg kg-1 + end do + +! 2M Diagnostics + Q1_2M (i, S) = vmr_resolved(km+1) ! kg kg-1 + + end do ! number of species loop s = 1, NUMB_MECH_SPC + +! Print up to KOUNT number of canopy columns + KOUNT = KOUNT + 1 +! + END IF ! loop over canopy columns FRT_MASK == 1. + + + END DO !I = 1, im !I-index + +! Done transferring from combined canopy + resolved scale back to resolved scale. :) +! +! ======================================================================== + else ! if (flag == 0) then (canopy_transfer == "resolved_to_canopy") then +! +! In: Q1_MOD +! +! Out: Q1_CAN (vmr_canopy) +! NB. ! Paul's trppm (mach_gas_canopy) is our vmr_canopy +! ======================================================================== +! + + DO i = 1, im !I-index + + KOUNT = 0 + + IF (FRT_mask(i) > 0.) THEN + +!...fetch all species and convert to kg kg-1 mass mixing ratio + DO S = 1, NTRAC-1 ! ntrac1= 197 (ntrac=ntke=198) +! DO ISP = 1, 1 ! ntqv=1 ntoz=7 nto3=11 + + ! S = CGRID_INDEX( ISP ) + +! Flip resolved layer arrays into a new array for use here +! (i): Model resolved layers + do k = 1, km + II = km + 1 - k ! from top to bottom of resolved model layers km+1 ??? + ! Paul's chem_tr is our conc3 = vmr_resolved (q1_mod) + ! conc3(1) is top model layer + ! conc3(km) is 1st (bottom) model layer + ! conc3(II) = Q1 (i, k, S) ! kg kg-1 + conc3(II) = Q1_MOD(i, k, S) ! kg kg-1 + vmr_resolved(II) = Q1_MOD(i, k, S) ! kg kg-1 + end do + +! (1) We start off by converting these mass mixing ratio [kg kg-1]to mass in [ug]: + do k = 1, km +! ...fetch gas mass mixing ratios [kg kg-1] and convert to [ug kg-1] + ! Paul's conc is our mmr_resolved + mmr_resolved(k) = REVERSE_CONV * conc3(k) ! ug kg-1 + end do + +! (1) Convert the original model domain values in the current column to mass from mass mixing ratio: +! mass_resolved = Mass mixing ratio * (density) / (volume of original model layer) (ug) + do k = 1, km + mass_resolved(k) = mmr_resolved(k) * massair(i, k) ! ug + end do + +! (2) Use the array fractions defined earlier to divide the resolved layer masses into the canopy layers, +! and convert back to mixing ratios. Note that the frctr2c fractions are vertical extent of the +! contribution of the resolved layer into the canopy layer, hence the mass/volume can be divided up +! this way: +! mmr_canopy = sum of masses contributed / (density * volume of canopy model layeri) + ! Paul's mmr_canopy is our mmr_canopy in ug kg-1 + ! Paul's masscan is our mass_canopy + mmr_canopy(:) = 0. + mass_canopy(:) = 0. + do k = 1, nkt + do kk = 1, nfrct(k, i) + kc = ifrct(k, kk, i) + mass_canopy(k) = mass_canopy(k) + mass_resolved(kc) * frctr2c(k, kk, i) ! ug + end do + end do + +! +! Check: total mass in the column should be the same + if (local_dbg) then + call canopy_mass_check(mass_canopy, mass_resolved, i, flag, nkc, nkt, errmsg, errflg) + if (errflg /= 0) return + end if +! + do k = 1, nkt + ! Paul's massaircan is our massair_can +! mmr_canopy(k) = mass_canopy(k) / max(massair_can(i, k), epsilon) ! ug kg-1 + mmr_canopy(k) = mass_canopy(k) / (massair_can(i, k)) ! ug kg-1 + +! Output diags +! ! if(S == 11) mmr_o3_can(i,k) = mmr_canopy(k) ! nto3=11 "resolved_to_canopy" +! if(S == 11) mmr_o3_can(i,k) = frctr2c(k, 1, i) ! "resolved_to_canopy" + if(S == 11) mmr_o3_can(i,k) = frctr2c(k, 2, i) + end do + + +! +! (3) Replace the original model layer values with the corresponding canopy layer values, when +! a canopy exists: + do kk = 1, km + k = kmod(i, kk) + ! Paul's chem_tr is our conc3 = vmr_resolved (q1_mod) <================ +! conc3(kk) = FORWARD_CONV * mmr_canopy(k) ! kg kg-1 + vmr_resolved (kk) = FORWARD_CONV * mmr_canopy(k) ! kg kg-1 + end do + +! (i): Model resolved layers: for hrdriver (trppm from mach_gas_canopy) + do kk = 1, km + ! kmod(1) is 1 top model layer + ! kmod(km) is 65 top canopy layer (modified after mono adj.) + k = kmod(i, kk) + + ! Paul's trppm is our vmr_canopy (conc_can) +! vmr_canopy(k) = conc3(kk) ! kg kg-1 + vmr_canopy(k) = vmr_resolved(kk) ! kg kg-1 + end do +! +! (4) Fill the canopy layers with the new mass mixing ratios + do kc = 1, nkc + k = kcan3(i, kc) + ! Paul's tracers_can is our conc_can3 <==================== + conc_can3(kc) = FORWARD_CONV * mmr_canopy(k) ! kg kg-1 + end do + +! (ii): Canopy shaded layers (for hrdriver) (trppm from mach_gas_canopy) + do kc = 1, nkc + ! Paul's trppm is our vmr_canopy (conc_can) + ! kcan3(1) = 65 + ! kcan3(2) = 66 + ! kcan3(3) = 67 + k = kcan3(i, kc) + vmr_canopy(k) = conc_can3(kc) ! kg kg-1 + end do + +! Prepare array for gas-phase chemical integration. (Paul's mach_gas_canopy) +! +! Flip back augmented canopy+resolved arrays for gas-phase integration (hrdriver) + do k = 1, nkt ! from top to bottom + II = nkt + 1 - k ! from bottom to top of resolved model layers + ! (nkt) is top model layer + ! (4) is 1hy model layer + ! (1-3) are canopy layers + ! Paul's trppm is our vmr_canopy (conc_can) + Q1_CAN(i, II, S) = vmr_canopy(k) ! kg kg-1 + end do + + end do !species index loop S (formerly isp) + +! Print up to KOUNT number of canopy columns + KOUNT = KOUNT + 1 + +! loop over canopy columns + END IF ! loop over canopy columns FRT_MASK == 1. +! + END DO !i = 1, im !I-index +! + end if ! 1="canopy_to_resolved" 0= "resolved_to_canopy" + + return + + contains + + subroutine canopy_mass_check(mass_canopy, mass_model, i, flag, nkc, nkt, errmsg, errflg) + implicit none + integer(kind=4), intent(in) :: flag, i, nkc, nkt + real(kind=kind_phys), intent(in) :: mass_canopy(nkt), mass_model(km) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + character(len=18) :: mode_transfer + real(kind=kind_phys) :: masstotcan, masstotres, massrat + real(kind=kind_phys) :: sum2can(nkt), sum2res(nkt) + + masstotcan = 0. + masstotres = 0. + do k = 1, nkt + masstotcan = masstotcan + mass_canopy(k) + end do + do k = 1, km + masstotres = masstotres + mass_model(k) + end do + + if (flag == 1) then + mode_transfer = "canopy_to_resolved" + else + mode_transfer = "resolved_to_canopy" + end if + +! if (masstotres > epsilon) then + if (masstotres > 0.0 ) then + massrat = masstotcan / masstotres + if (massrat > 1.001 .or. massrat < 0.999) then + write(errmsg,fmt='(*(a,f10.4,a,f10.4))') 'Conversion of mass in ccpp_canopy_transfer not conserved ' // & + 'during ' // mode_transfer // ' evaluation. masstotcan = ', masstotcan, & + ' and masstotres = ', masstotres + errflg = 1 + return + end if + end if +! +! Check on the values of the fractions: they should sum to unity across the number +! of original model levels! + sum2can = 0. + sum2res = 0. + do k = nkt, 1, -1 + do kk = 1, nfrct(k, i) + kc = ifrct(k, kk, i) + sum2can(kc) = sum2can(kc) + frctr2c(k, kk, i) + sum2res(k) = sum2res(k) + frctc2r(k, kk, i) + end do + end do + + do k = km , 1, -1 + if (sum2can(k) < 0.999 .or. sum2can(k) > 1.001) then + write(errmsg,fmt='(*(a,i0,a,i0,a,f10.4))') 'layer mismatch in canopy level setup in resolved to canopy indexing: ' // & + 'column ', i, ' layer ', k, ' sum=', sum2can(k) + errflg = 1 + return + end if + end do + do k = nkt, 1, -1 + if (sum2res(k) < 0.999 .or. sum2res(k) > 1.001) then + write(errmsg,fmt='(*(a,i0,a,i0,a,f10.4))') 'layer mismatch in canopy level setup in canopy to resolved indexing: ' // & + 'column ', i, ' layer ', k, ' sum=', sum2res(k) + errflg = 1 + return + end if + end do + +! + return + end subroutine canopy_mass_check + + end subroutine canopy_transfer_run + + end module canopy_transfer_mod diff --git a/physics/PBL/SATMEDMF/satmedmfvdifq.F b/physics/PBL/SATMEDMF/satmedmfvdifq.F index 5ebb947ac..52fabc310 100644 --- a/physics/PBL/SATMEDMF/satmedmfvdifq.F +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.F @@ -98,14 +98,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku,tkeh, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm,tc_pbl,use_lpt, & -!IVAI: canopy inputs from AQM & do_canopy, cplaqm, claie, cfch, cfrt, cclu, cpopu, & -!IVAI & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & & errmsg,errflg) -!IVAI: aux arrays -! & naux2d,naux3d,aux2d,aux3d) ! use machine , only : kind_phys @@ -130,7 +126,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: rlmx, elmx !PCC CANOPY------------------------------------ logical, intent(in) :: do_canopy, cplaqm -!IVAI: canopy inputs real(kind=kind_phys), optional, intent(in) :: claie(:), cfch(:), & & cfrt(:), cclu(:), cpopu(:) !---------------------------------------------- @@ -322,16 +317,18 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ integer COUNTCAN,KCAN - integer kount !IVAI + integer kount real(kind=kind_phys) FCH, MOL, HOL, TLCAN, & SIGMACAN, RRCAN, BBCAN, & AACAN, ZCAN, ZFL, BOTCAN, + & ZZ_INT, & EDDYVEST1, EDDYVEST_INT ! in canopy eddy diffusivity [ m**2/s ] real(kind=kind_phys), allocatable :: EDDYVESTX ( : ) ! in canopy layer [m] real(kind=kind_phys), allocatable :: ZCANX ( : ) + real(kind=kind_phys), allocatable :: ZOOOX ( : ) ! Declare local maximum canopy layers integer, parameter :: MAXCAN = 1000 integer, parameter :: mvt = 30 ! use 30 instead of 27 @@ -344,14 +341,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & 2.00, 0.50, 0.00, 0.00, 0.00, 0.00, & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / !---------------------------------------------- - -!IVAI -! integer, intent(in) :: naux2d,naux3d -! real(kind_phys), intent(inout) :: aux2d(:,:) -! real(kind_phys), intent(inout) :: aux3d(:,:,:) -!IVAI - -!! parameter(bfac=100.) parameter(wfac=7.0) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) @@ -379,13 +368,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(cptke1=0.07,cptke2=0.142,cptke3=0.071) parameter(dkmaxles=300.0,sclmin=500.,sclmax=2500.) parameter(elmhfac=1.5,elmhmx=1000.,ckh=0.4) -! + !PCC_CANOPY------------------------------------ if (do_canopy) then if(.not.allocated(EDDYVESTX)) & allocate( EDDYVESTX ( MAXCAN ) ) if(.not.allocated(ZCANX)) & allocate( ZCANX ( MAXCAN ) ) + if(.not.allocated(ZOOOX)) + & allocate( ZOOOX ( MAXCAN ) ) endif !---------------------------------------------- if (tc_pbl == 0) then @@ -397,7 +388,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ch0 = 0.55 ce0 = 0.12 endif -! + if(tte_edmf) then cfac = 3.0 prmax = 6.0 @@ -411,14 +402,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ck1 = 0.15 ch1 = 0.15 endif -! + gravi = 1.0 / grav g = grav gocp = g / cp -! 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) !kpa elocp = hvap / cp el2orc = hvap * hvap / (rv * cp) ! @@ -1716,30 +1703,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif !sa3dtke !PCC_CANOPY------------------------------------ - kount=0 !IVAI if (do_canopy .and. cplaqm) then -!IVAI -! print*, 'SATMEDMFVDIFQ_RUN: CLAIE = ', claie(:) -! print*, 'SATMEDMFVDIFQ_RUN: CFCH = ' , cfch (:) -! print*, 'SATMEDMFVDIFQ_RUN: CFRT = ' , cfrt (:) -! print*, 'SATMEDMFVDIFQ_RUN: CCLU = ' , cclu (:) -! print*, 'SATMEDMFVDIFQ_RUN: CPOPU= ' , cpopu(:) -! 2D aux arrays: canopy data in diffusion -! aux2d(:,1) = cfch (:) -! aux2d(:,2) = claie(:) -! aux2d(:,3) = cfrt(:) - -! 3D aux arrays: before canopy correction -! aux3d(:,:,1) = dkq(:,:) -! aux3d(:,:,2) = dkt(:,:) -! aux3d(:,:,3) = dku(:,:) -!IVAI do k = 1, km1-1 + + kount=0 !IVAI + ZOOOX(:) = 1. ! IVAI + do i = 1, im -!IVAI: AQM canopy Inputs -! FCH = fch_table(vegtype(i)) !top of canopy from look-up table FCH = cfch(i) !top of canopy from AQM canopy inputs IF (k .EQ. 1) THEN !use model layer interfaces KCAN = 1 @@ -1755,36 +1727,16 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & IF (KCAN .EQ. 1) THEN !canopy inside model layer ! Check for other Contiguous Canopy Grid Cell Conditions -! Not a contigous canopy cell +! Not a contiguous canopy cell IF ( claie(i) .LT. 0.1 & .OR. cfch (i) .LT. 0.5 -!IVAI: modified contiguous canopy condition -! & .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.5 & .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.75 -!IVAI & .OR. cpopu(i) .GT. 10000.0 & .OR. (EXP(-0.5*claie(i)*cclu(i)) .GT. 0.45 & .AND. cfch(i) .LT. 18.) ) THEN - -!TODO: Canopy Inputs -! IF ( XCANOPYLAI .LT. 0.1 !from canopy inputs -! IF ( lai(i) .LT. 0.1 !from LSM -! & .OR. FCH .LT. 0.5 ) THEN -! & .OR. MAX(0.0, 1.0 - XCANOPYFRT) .GT. 0.5 -! & .OR. POPU .GT. 10000.0 -! & .OR. EXP(-0.5*XCANOPYLAI*XCANOPYCLU).GT. 0.45 -! & .AND. FCH .LT. 18.0 ) THEN - - dkt(i,k)= dkt(i,k) - dkq(i,k)= dkq(i,k) - dku(i,k)= dku(i,k) - ELSE ! There is a contiguous forest canopy, apply correction over canopy layers -! Output contiguous canopy mask -! if (kount .EQ. 0 ) aux2d(i,5) = aux2d(i,5) + 1 - !Raupauch M. R. A Practical Lagrangian method for relating scalar !concentrations to ! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. @@ -1797,7 +1749,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & COUNTCAN = 0 ! Initialize canopy layers IF (k .EQ. 1) THEN !Find bottom in each model layer - BOTCAN = 0.5 + BOTCAN = 0.0 ! 0.5 (Jan10) ELSE BOTCAN = zi(i,k) END IF @@ -1855,34 +1807,57 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & IF ( HOL .GE. 0.9 ) THEN !VERY STABLE SIGMACAN = 0.25*ustar(i) END IF - IF ( ZCAN .EQ. ZFL ) THEN ! Each model layer that includes canopy - EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN - ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays - COUNTCAN = COUNTCAN + 1 - ZCANX (COUNTCAN) = ZCAN - EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN + + IF ( ZCAN .EQ. ZFL ) ! THEN ! Each model layer that includes canopy + & EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN ! Model-layer top diffusivity + +! Average In-Canopy diffusivity gives larger canopy correction (2022) +! IF ( ZCAN .LE. FCH ) THEN ! Average In-Canopy diffusivity (2022) +! Average model-layer diffusivity gives smaller canopy correction (pre-2022) & Jan9, 2026 + IF ( ZCAN .LE. ZFL ) THEN ! Average model-layer diffusivity (2026) + + COUNTCAN = COUNTCAN + 1 + ZCANX (COUNTCAN) = ZCAN + EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN + END IF + ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m + END DO !end loop on canopy layers - EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1) - & ),EDDYVESTX(COUNTCAN:1:-1)) / ZFL + + IF (COUNTCAN > 0 ) THEN + + IF (COUNTCAN .EQ. 1) THEN + ZZ_INT= ZCANX(COUNTCAN) ! FCH (set to FCH if COUNTCAN is 1) + ELSE + ZZ_INT= IntegrateTrapezoid( + & ZCANX(COUNTCAN:1:-1), ZOOOX(COUNTCAN:1:-1)) + END IF + + IF (COUNTCAN .EQ. 1) THEN + EDDYVEST_INT = EDDYVESTX(COUNTCAN) + ELSE + + EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1) + & ),EDDYVESTX(COUNTCAN:1:-1)) / + & ZZ_INT + END IF + +! Comment out to turn OFF the integrated canopy effect dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity dku(i,k)= (dku(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity -!IVAI: Output contiguos canopy correction bottom layer and 3D -! if ( kount .EQ. 0) -! & aux2d(i,4) = 1./EDDYVEST1 * EDDYVEST_INT -! aux3d(i,k,4) = 1./EDDYVEST1 * EDDYVEST_INT -!IVAI + END IF ! (COUNTCAN > 0) - END IF ! contigous canopy conditions + END IF ! contiguous canopy conditions END IF ! (KCAN .EQ. 1) model layer(s) containing canopy enddo !i - kount = kount + 1 !IVAI + kount = kount + 1 enddo !k @@ -1964,7 +1939,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ptem = 0. endif ptem2 = ptem2 + ptem -! + tem2 = stress(i)*ustar(i)*phims(i)/(vk*zl(i,1)) shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2) else diff --git a/physics/PBL/SATMEDMF/satmedmfvdifq_can.F b/physics/PBL/SATMEDMF/satmedmfvdifq_can.F new file mode 100644 index 000000000..a3332101b --- /dev/null +++ b/physics/PBL/SATMEDMF/satmedmfvdifq_can.F @@ -0,0 +1,2904 @@ +!> \file satmedmfvdifq_can.F + +!> This file contains the CCPP-compliant SATMEDMF scheme (updated version) which +!! computes subgrid vertical turbulence mixing using scale-aware TKE-based moist +!! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). + +!! if(tte_edmf=.true.), the TKE-EDMF parameterization becomes +!! TTE(total turbulent energy)-based moist (TTE-EDMF) parameterization +!! + module satmedmfvdifq_can_mod + + contains + +!> \defgroup module_satmedmfvdifq_can GFS TKE-EDMF PBL Module +!! This file contains the CCPP-compliant SATMEDMF scheme (updated version) which +!! computes subgrid vertical turbulence mixing using scale-aware TKE-based moist +!! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). +!> @{ +!! \brief This subroutine contains all of the logic for the +!! scale-aware TKE-based moist eddy-diffusion mass-flux (TKE-EDMF, updated version) scheme. +!! For local turbulence mixing, a TKE closure model is used. +!! Updated version of satmedmfvdif.f to have better low level +!! inversion, to reduce the cold bias in lower troposphere, +!! and to reduce the negative wind speed bias in upper troposphere +!! +!! Incorporate the LES-based changes for TC simulation +!! (Chen et al.,2022 \cite Chen_2022) +!! with additional improvements on MF working with Cu schemes. +!! +!! Incorporate the TTE-EDMF; if (tte_edmf=.true.), +!! TKE-EDMF scheme becomes TTE-EDMF scheme and the variable 'te' +!! is read as TTE; if (tte_edmf=.false.), the variable 'te' is +!! read as TKE. +!! +!! +!> \section arg_table_satmedmfvdifq_can Argument Table +!! \htmlinclude satmedmfvdifq_can.html +!! +!!\section gen_satmedmfvdifq GFS satmedmfvdifq General Algorithm +!! satmedmfvdifq_can() computes subgrid vertical turbulence mixing +!! using the scale-aware TKE-based moist eddy-diffusion mass-flux (EDMF) parameterization of +!! Han and Bretherton (2019) \cite Han_2019 . +!! -# The local turbulent mixing is represented by an eddy-diffusivity scheme which +!! is a function of a prognostic TKE. +!! -# For the convective boundary layer, nonlocal transport by large eddies +!! (mfpbltq.f), is represented using a mass flux approach (Siebesma et al.(2007) \cite Siebesma_2007 ). +!! -# A mass-flux approach is also used to represent the stratocumulus-top-induced turbulence +!! (mfscuq.f). +!! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm + subroutine satmedmfvdifq_can(im,km,ntrac,ntcw,ntrw, + & ntiw,ntke,grav,pi,rd,cp,rv,hvap,hfus,fv,eps,epsm1, +!The following three variables are for SA-3D-TKE + & def_1,def_2,def_3,sa3dtke,dku3d_h,dku3d_e, + & dv,du,tdt,rtg,u1,v1,t1,q1,usfco,vsfco,use_oceanuv, + & swh,hlw,xmu,garea,zvfun,sigmaf, + & psk,rbsoil,zorl,u10m,v10m,fm,fh, + & tsea,heat,evap,stress,spd1,kpbl, + & prsi,del,prsl,prslk,phii,phil,delt,tte_edmf, + & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku,tkeh, + & dkt_can, dku_can, + & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, + & rlmx,elmx,sfc_rlm,tc_pbl,use_lpt, + & do_canopy, cplaqm, + & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, + & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, + & errmsg,errflg) +!IVAI: aux arrays +! & naux2d,naux3d,aux2d,aux3d) + +! + use machine , only : kind_phys + use funcphys , only : fpvs + use mfpbltq_mod + use tridi_mod + use mfscuq_mod +! + !PCC_CANOPY_utilities + use canopy_utils_mod +! + implicit none +! +!---------------------------------------------------------------------- + integer, intent(in) :: im, km, ntrac, ntcw, ntrw, ntiw, + & ntke, ntqv + integer, intent(in) :: sfc_rlm + integer, intent(in) :: tc_pbl + integer, intent(in) :: use_lpt + integer, intent(in) :: kinver(:) + integer, intent(out) :: kpbl(:) + logical, intent(in) :: gen_tend,ldiag3d +! + real(kind=kind_phys), intent(in) :: grav,pi,rd,cp,rv,hvap,hfus,fv, + & eps,epsm1 + real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr + real(kind=kind_phys), intent(in) :: rlmx, elmx +!PCC CANOPY------------------------------------ + logical, intent(in) :: do_canopy, cplaqm + real(kind=kind_phys), optional, intent(in) :: + & dkt_can(:,:), dku_can(:,:) + !---------------------------------------------- + real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), + & tdt(:,:), rtg(:,:,:), tkeh(:,:) + real(kind=kind_phys), intent(in) :: + & u1(:,:), v1(:,:), + & usfco(:), vsfco(:), + & t1(:,:), q1(:,:,:), +!The following two variables are for SA-3D-TKE + & def_1(:,:), def_2(:,:), def_3(:,:), + & swh(:,:), hlw(:,:), + & xmu(:), garea(:), + & zvfun(:), sigmaf(:), + & psk(:), rbsoil(:), + & zorl(:), tsea(:), + & u10m(:), v10m(:), + & fm(:), fh(:), + & evap(:), heat(:), + & stress(:), spd1(:), + & prsi(:,:), del(:,:), + & prsl(:,:), prslk(:,:), + & phii(:,:), phil(:,:) + real(kind=kind_phys), intent(inout), dimension(:,:,:), optional :: + & dtend + integer, intent(in) :: dtidx(:,:), index_of_temperature, + & index_of_x_wind, index_of_y_wind, index_of_process_pbl + logical, intent(in) :: use_oceanuv + real(kind=kind_phys), intent(out) :: + & dusfc(:), dvsfc(:), + & dtsfc(:), dqsfc(:), + & hpbl(:) + real(kind=kind_phys), intent(out) :: + & dkt(:,:), dku(:,:) + +! + logical, intent(in) :: sa3dtke !flag for SA-3D-TKE scheme +! +! flag for tke dissipative heating + logical, intent(in) :: dspheat +! flag for TTE-EDMF scheme + logical, intent(in) :: tte_edmf +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!For passing dku to the dyn_core (SA-3D-TKE scheme) + real(kind=kind_phys), intent(out) :: + & dku3d_h(:,:),dku3d_e(:,:) + +! +!---------------------------------------------------------------------- +!*** +!*** local variables + real(kind=kind_phys) spd1_m +!*** + integer i,is,k,n,ndt,km1,kmpbl,kmscu,ntrac1,idtend + integer kps,kbx,kmx + integer lcld(im),kcld(im),krad(im),mrad(im) + integer kx1(im), kb1(im), kpblx(im) +! + real(kind=kind_phys) te(im,km), tei(im,km-1), tke(im,km), + & tteh(im,km), tesq(im,km-1),e2(im,0:km) +! + real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), + & qlx(im,km), thetae(im,km),thlx(im,km), + & slx(im,km), svx(im,km), qtx(im,km), + & tvx(im,km), pix(im,km), radx(im,km-1), + & dkq(im,km-1) +! + real(kind=kind_phys) plyr(im,km), rhly(im,km), cfly(im,km), + & qstl(im,km) +! + real(kind=kind_phys) dtdz1(im), gdx(im), + & phih(im), phim(im), phihs(im), + & phims(im), prn(im,km-1), + & rbdn(im), rbup(im), thermal(im), + & ustar(im), wstar(im), hpblx(im), + & ust3(im), wst3(im), rho_a(im), + & z0(im), crb(im), tkemean(im), + & hgamt(im), hgamq(im), + & wscale(im),vpert(im), thvs(im), + & zol(im), sflux(im), ris(im), + & sumx(im), tx1(im), tx2(im) +! + real(kind=kind_phys) radmin(im) +! + real(kind=kind_phys) zi(im,km+1), zl(im,km), zm(im,km), + & xkzo(im,km-1),xkzmo(im,km-1), + & xkzm_hx(im), xkzm_mx(im), tkmnz(im,km-1), + & rdzt(im,km-1),rlmnz(im,km), + & al(im,km-1), ad(im,km), au(im,km-1), + & f1(im,km), f2(im,km*(ntrac-1)) +! + real(kind=kind_phys) elm(im,km), ele(im,km), + & ckz(im,km), chz(im,km), + & diss(im,km-1),prod(im,km-1), + & bf(im,km-1), shr2(im,km-1), wush(im,km), + & xlamue(im,km-1), xlamde(im,km-1), + & gotvx(im,km), rlam(im,km-1) +! +! variables for updrafts (thermals) +! + real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), + & ucko(im,km), vcko(im,km), + & buou(im,km), xmf(im,km) +! +! variables for stratocumulus-top induced downdrafts +! + real(kind=kind_phys) tcdo(im,km), qcdo(im,km,ntrac), + & ucdo(im,km), vcdo(im,km), + & buod(im,km), xmfd(im,km) +! +! variables for Total Variation Diminishing (TVD) flux-limiter scheme +! + real(kind=kind_phys) e_half(im,km-1), e_diff(im,0:km-1), + & q_half(im,km-1,ntrac-1), + & qh(im,km-1,ntrac-1), + & q_diff(im,0:km-1,ntrac-1) + real(kind=kind_phys) rrkp, phkp + real(kind=kind_phys) tsumn(im), tsump(im), rtnp(im) + real(kind=kind_phys) sfcpbl(im), vez0fun(im) +! + logical pblflg(im), sfcflg(im), flg(im) + logical scuflg(im), pcnvflg(im) + logical mlenflg +! +! pcnvflg: true for unstable pbl +! + real(kind=kind_phys) aphi16, aphi5, + & wfac, cfac, + & gamcrt, gamcrq, sfcfrac, +! & conq, cont, conw, + & dsdz2, dsdzt, dkmax, + & dsig, dt2, dtodsd, + & dtodsu, g, factor, dz, + & gocp, gravi, zol1, zolcru, + & buop, shrp, dtn, + & prnum, prmax, prmin, prtke, + & prscu, pr0, ri, + & dw2, dw2min, zk, + & elmfac, elefac, dspmax, + & alp, clwt, cql, + & f0, robn, crbmin, crbmax, + & es, qs, value, onemrh, + & cfh, gamma, elocp, el2orc, + & epsi, beta, chx, cqx, + & rdt, rdz, qmin, qlmin, + & rimin, rbcr, rbint, tdzmin, + & rlmn, rlmn0, rlmn1, rlmn2, + & ttend, utend, vtend, qtend, + & zfac, zfmin, vk, spdk2, + & tkmin, tkbmx, disste, xkgdx, + & xkinv1, xkinv2, + & zlup, zldn, cs0, csmf, + & tem, tem1, tem2, tem3, + & ptem, ptem0, ptem1, ptem2 +! +!The following variables are for SA-3D-TKE + integer kk + real(kind=kind_phys) thetal(im,km),dku_les(im,km),dkt_les(im,km), + & elmh(im,km),ele_les(im,km),pftke(im), + & dkq_les(im,km),pfl(im),pfdx(im), + & dku_h(im,km),dkq_h(im,km), + & elmhfac,elmhmx,ckh,elm_les, + & cpl1,cpl2,cpl3,cpl4,cpl5,cpl6, + & cptke1,cptke2,cptke3 + integer ktkemax(im) + real(kind=kind_phys) tkemax(im),scl(im) + real(kind=kind_phys) sclmax,sclmin,dkmaxles +! end of SA-3D-TKE variables +! + real(kind=kind_phys) slfac +! + real(kind=kind_phys) vegflo, vegfup, z0lo, z0up, vc0, zc0 +! + real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck +! +! + real(kind=kind_phys) epotte +! + real(kind=kind_phys) qlcr, zstblmax, hcrinv +! + real(kind=kind_phys) h1 + + real(kind=kind_phys) bfac, mffac + + real(kind=kind_phys) qice(im,km),qliq(im,km) + +!PCC_CANOPY------------------------------------ + integer kount !IVAI +!---------------------------------------------- + +!IVAI +! integer, intent(in) :: naux2d,naux3d +! real(kind_phys), intent(inout) :: aux2d(:,:) +! real(kind_phys), intent(inout) :: aux3d(:,:,:) +!IVAI + +!! + parameter(bfac=100.) + parameter(wfac=7.0) + parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) + parameter(vk=0.4,rimin=-100.,slfac=0.1) + parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) + parameter(rlmn=30.,rlmn0=5.,rlmn1=5.,rlmn2=10.) + parameter(prmin=0.25) + parameter(pr0=1.0,prtke=1.0) + parameter(f0=1.e-4,crbmin=0.15,crbmax=0.35) + parameter(tkmin=1.e-9,tkbmx=0.2,dspmax=10.0) + parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) + parameter(aphi5=5.,aphi16=16.) + parameter(elmfac=1.0,elefac=1.0,cql=100.) + parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=1000.) + parameter(qlcr=3.5e-5,zstblmax=2500.) + parameter(xkinv1=0.15,xkinv2=0.3) + parameter(h1=0.33333333,hcrinv=250.) + parameter(vegflo=0.1,vegfup=1.0,z0lo=0.1,z0up=1.0) + parameter(vc0=1.0,zc0=1.0) + parameter(cs0=0.4,csmf=0.5) + parameter(rchck=1.5,ndt=20) + !The following variables are for SA-3D-TKE + parameter(cpl1=0.280,cpl2=0.870,cpl3=0.913) + parameter(cpl4=0.153,cpl5=0.278,cpl6=0.720) + parameter(cptke1=0.07,cptke2=0.142,cptke3=0.071) + parameter(dkmaxles=300.0,sclmin=500.,sclmax=2500.) + parameter(elmhfac=1.5,elmhmx=1000.,ckh=0.4) +! +!PCC_CANOPY------------------------------------ + if (do_canopy) then +! Initialize layer thickness in non-canopy columns + rdzt(:,:) = 0.0 ! IVAI + endif +!---------------------------------------------- + if (tc_pbl == 0) then + ck0 = 0.4 + ch0 = 0.4 + ce0 = 0.4 + else if (tc_pbl == 1) then + ck0 = 0.55 + ch0 = 0.55 + ce0 = 0.12 + endif +! + if(tte_edmf) then + cfac = 3.0 + prmax = 6.0 + prscu = 0.4 + ck1 = 0.16 + ch1 = 0.16 + else + cfac = 4.5 + prmax = 4.0 + prscu = 0.67 + ck1 = 0.15 + ch1 = 0.15 + endif +! + gravi = 1.0 / grav + g = grav + gocp = g / cp +! 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) !kpa + elocp = hvap / cp + el2orc = hvap * hvap / (rv * cp) +! +!************************************************************************ +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!> ## Compute preliminary variables from input arguments + dt2 = delt + rdt = 1. / dt2 +! +! the code is written assuming ntke=ntrac +! if ntrac > ntke, the code needs to be modified +! + ntrac1 = ntrac - 1 + km1 = km - 1 + kmpbl = km / 2 + kmscu = km / 2 +!> - Compute physical height of the layer centers and interfaces from +!! the geopotential height (\p zi and \p zl) + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + xmf(i,k) = 0. + xmfd(i,k) = 0. + buou(i,k) = 0. + buod(i,k) = 0. + wush(i,k) = 0. + ckz(i,k) = ck1 + chz(i,k) = ch1 + rlmnz(i,k) = rlmn0 + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo + do k=1,km + do i=1,im + zm(i,k) = zi(i,k+1) + enddo + enddo +!> - Compute horizontal grid size (\p gdx) + do i=1,im + gdx(i) = sqrt(garea(i)) + enddo +!> - Initialize tke value at vertical layer centers and interfaces +!! from tracer (\p tke and \p tkeh) + do k=1,km + do i=1,im + te(i,k) = max(q1(i,k,ntke), tkmin) + tkeh(i,k) = 0 + tteh(i,k) = 0 + enddo + enddo + if(tte_edmf) then + do k=1,km1 + do i=1,im + tteh(i,k) = 0.5 * (te(i,k) + te(i,k+1)) + enddo + enddo + else + do k = 1, km + do i = 1, im + tke(i,k) = te(i,k) + enddo + enddo + do k=1,km1 + do i=1,im + tkeh(i,k) = 0.5 * (tke(i,k) + tke(i,k+1)) + enddo + enddo + endif +!> - 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)) + prn(i,k) = pr0 + enddo + enddo +! +!> - Compute reciprocal of pressure (tx1, tx2) + +!> - Compute minimum turbulent mixing length (rlmnz) + +!> - Compute background vertical diffusivities for scalars and momentum (xkzo and xkzmo) + +!> - set background diffusivities with xkzm_h & xkzm_m for gdx >= xkgdx and +!! as a function of horizontal grid size for gdx < xkgdx +!! \n xkzm_hx = xkzm_h * (gdx / xkgdx) +!! \n xkzm_mx = xkzm_m * (gdx / xkgdx) +! + do i=1,im + kx1(i) = 1 + tx1(i) = 1.0 / prsi(i,1) + tx2(i) = tx1(i) + if(gdx(i) >= xkgdx) then + xkzm_hx(i) = xkzm_h + xkzm_mx(i) = xkzm_m + else + tem = gdx(i) / xkgdx + xkzm_hx(i) = xkzm_h * tem + xkzm_mx(i) = xkzm_m * tem + endif + enddo + do k = 1,km1 + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! minimum turbulent mixing length + ptem = prsi(i,k+1) * tx1(i) + tem1 = 1.0 - ptem + tem2 = tem1 * tem1 * 2.5 + tem2 = min(1.0, exp(-tem2)) + rlmnz(i,k)= rlmn * tem2 + rlmnz(i,k)= max(rlmnz(i,k), rlmn0) +! vertical background diffusivity + tem2 = tem1 * tem1 * 10.0 + tem2 = min(1.0, exp(-tem2)) + xkzo(i,k) = xkzm_hx(i) * tem2 +! vertical background diffusivity for +! momentum + if (ptem >= xkzm_s) then + xkzmo(i,k) = xkzm_mx(i) + 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_mx(i) * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! +!> - Some output variables and logical flags are initialized + do i = 1,im + z0(i) = 0.01 * zorl(i) + rho_a(i) = prsl(i,1)/(rd*t1(i,1)*(1.+fv*max(q1(i,1,1),qmin))) + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + kpbl(i) = 1 + hpbl(i) = 0. + kpblx(i) = 1 + hpblx(i) = 0. + pfl(i)=1.0 + pftke(i)=1.0 + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + pcnvflg(i)= .false. + scuflg(i)= .true. + if(scuflg(i)) then + radmin(i)= 0. + mrad(i) = km1 + krad(i) = 1 + lcld(i) = km1 + kcld(i) = km1 + endif + enddo +! +!> - Compute a function for green vegetation fraction and surface roughness. +!! Entrainment rate in updraft is a function of vegetation fraction and surface +!! roughness length +! + do i = 1,im + tem = (sigmaf(i) - vegflo) / (vegfup - vegflo) + tem = min(max(tem, 0.), 1.) + tem1 = sqrt(tem) + ptem = (z0(i) - z0lo) / (z0up - z0lo) + ptem = min(max(ptem, 0.), 1.) + vez0fun(i) = (1. + vc0 * tem1) * (1. + zc0 * ptem) + enddo +! +!> - Compute \f$\theta\f$(theta), and \f$q_l\f$(qlx), \f$\theta_e\f$(thetae), +!! \f$\theta_v\f$(thvx),\f$\theta_{l,v}\f$ (thlvx) including ice water + do k=1,km + do i=1,im + pix(i,k) = psk(i) / prslk(i,k) + theta(i,k) = t1(i,k) * pix(i,k) + qice(i,k) = 0.0 + qliq(i,k) = 0.0 + if(ntiw > 0) then + tem = max(q1(i,k,ntcw),qlmin) + qliq(i,k) = tem + if(sa3dtke) then + tem1=max(q1(i,k,ntiw)+q1(i,k,5)+q1(i,k,6),qlmin) !for SA-3D-TKE + qice(i,k) = tem1 + else + tem1=max(q1(i,k,ntiw),qlmin) + qice(i,k) = tem1 + endif + qlx(i,k) = tem + tem1 + ptem = hvap*tem + (hvap+hfus)*tem1 + slx(i,k) = cp * t1(i,k) + phil(i,k) - ptem + else + qlx(i,k) = max(q1(i,k,ntcw),qlmin) + slx(i,k) = cp * t1(i,k) + phil(i,k) - hvap*qlx(i,k) + qliq(i,k) = qlx(i,k) + endif + tem2 = 1.+fv*max(q1(i,k,1),qmin)-qlx(i,k) + thvx(i,k) = theta(i,k) * tem2 + tvx(i,k) = t1(i,k) * tem2 + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + thlx(i,k) = theta(i,k) - pix(i,k)*elocp*qlx(i,k) + thlvx(i,k) = thlx(i,k) * (1. + fv * qtx(i,k)) + svx(i,k) = cp * tvx(i,k) + ptem1 = elocp * pix(i,k) * max(q1(i,k,1),qmin) + thetae(i,k)= theta(i,k) + ptem1 +! gotvx(i,k) = g / tvx(i,k) + gotvx(i,k) = g / thvx(i,k) + enddo + enddo +! +!> - Compute an empirical cloud fraction based on +!! Xu and Randall (1996) \cite xu_and_randall_1996 + do k = 1, km + do i = 1, im + plyr(i,k) = 0.01 * prsl(i,k) ! pa to mb (hpa) +! --- ... compute relative humidity + es = 0.01 * fpvs(t1(i,k)) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k) + epsm1*es)) + rhly(i,k) = max(0.0, min(1.0, max(qmin, q1(i,k,1))/qs)) + qstl(i,k) = qs + enddo + enddo +! + do k = 1, km + do i = 1, im + cfly(i,k) = 0. + clwt = 1.0e-6 * (plyr(i,k)*0.001) + if (qlx(i,k) > clwt) then + onemrh = max(1.e-10, 1.0-rhly(i,k)) + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) + tem1 = cql / tem1 + value = max(min( tem1*qlx(i,k), 50.0), 0.0) + tem2 = sqrt(sqrt(rhly(i,k))) + cfly(i,k) = min(max(tem2*(1.0-exp(-value)), 0.0), 1.0) + endif + enddo + enddo +! +!> - Compute buoyancy modified by clouds +! + do k = 1, km1 + do i = 1, im + tem = 0.5 * (svx(i,k) + svx(i,k+1)) + tem1 = 0.5 * (t1(i,k) + t1(i,k+1)) + tem2 = 0.5 * (qstl(i,k) + qstl(i,k+1)) + cfh = min(cfly(i,k+1),0.5*(cfly(i,k)+cfly(i,k+1))) + alp = g / tem + gamma = el2orc * tem2 / (tem1**2) + epsi = tem1 / elocp + beta = (1. + gamma*epsi*(1.+fv)) / (1. + gamma) + chx = cfh * alp * beta + (1. - cfh) * alp + cqx = cfh * alp * hvap * (beta - epsi) + cqx = cqx + (1. - cfh) * fv * g + ptem1 = (slx(i,k+1)-slx(i,k))*rdzt(i,k) + ptem2 = (qtx(i,k+1)-qtx(i,k))*rdzt(i,k) + bf(i,k) = chx * ptem1 + cqx * ptem2 + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!> - Initialize diffusion coefficients to 0 and calculate the total +!! radiative heating rate (dku, dkt, radx) + do k=1,km + do i=1,im + dku(i,k) = 0. + dkt(i,k) = 0. + enddo + enddo + do k=1,km1 + do i=1,im + dkq(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 +!> - Compute stable/unstable PBL flag (pblflg) based on the total +!! surface energy flux (\e false if the total surface energy flux +!! is into the surface) + 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 PBL height +!! 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. +!! - Compute critical bulk Richardson number (\f$Rb_{cr}\f$) (crb) +!! - For the unstable PBL, crb is a constant (0.25) +!! - For the stable boundary layer (SBL), \f$Rb_{cr}\f$ varies +!! with the surface Rossby number, \f$R_{0}\f$, as given by +!! Vickers and Mahrt (2004) \cite Vickers_2004 +!! \f[ +!! Rb_{cr}=0.16(10^{-7}R_{0})^{-0.18} +!! \f] +!! \f[ +!! R_{0}=\frac{U_{10}}{f_{0}z_{0}} +!! \f] +!! where \f$U_{10}\f$ is the wind speed at 10m above the ground surface, +!! \f$f_0\f$ the Coriolis parameter, and \f$z_{0}\f$ the surface roughness +!! length. To avoid too much variation, we restrict \f$Rb_{cr}\f$ to vary +!! within the range of 0.15~0.35 + do i = 1,im + thvs(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + if(pblflg(i)) then +! thermal(i) = thvx(i,1) + thermal(i) = thlvx(i,1) + crb(i) = rbcr + else + thermal(i) = thvs(i) + 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 +!> - Compute \f$\frac{\Delta t}{\Delta z}\f$ , \f$u_*\f$ + do i=1,im + dtdz1(i) = dt2 / (zi(i,2)-zi(i,1)) + enddo +! + do i=1,im + ustar(i) = sqrt(stress(i)) + enddo +! +!> - Compute buoyancy \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) = gotvx(i,k)*(thvx(i,k+1)-thvx(i,k))*rdz + 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 +! +! Find first quess pbl height based on bulk richardson number (mrf pbl scheme) +! and also for diagnostic purpose +! + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + enddo +!> - Given the thermal's properties and the critical Richardson number, +!! a loop is executed to find the first level above the surface (kpblx) where +!! the modified Richardson number is greater than the critical Richardson +!! number, using equation 10a from Troen and Mahrt (1996) \cite troen_and_mahrt_1986 +!! (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): + do k = 1, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + if (tc_pbl == 0) then + 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 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + else if (tc_pbl == 1) then + spdk2 = max((u1(i,k)-u1(i,1))**2+(v1(i,k)-v1(i,1))**2,1.) + & + bfac*ustar(i)**2 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*(zl(i,k)-zl(i,1))/thlvx(i,1))/spdk2 + endif + kpblx(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$R_{i} > Rb_{cr}\f$) +!! and the PBL height (hpbl and kpbl) and the PBL top index are saved. + do i = 1,im + if(kpblx(i) > 1) then + k = kpblx(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 + hpblx(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpblx(i) < zi(i,kpblx(i))) kpblx(i)=kpblx(i)-1 + else + hpblx(i) = zl(i,1) + kpblx(i) = 1 + endif + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + if(kpbl(i) <= 1) pblflg(i)=.false. + enddo +! +! update thermal at a level of slfac*hpbl for unstable pbl +! + do i=1,im + sfcpbl(i) = slfac * hpbl(i) + kb1(i) = 1 + flg(i) = .false. + if(pblflg(i)) then + flg(i) = .true. + endif + enddo + do k = 2, kmpbl + do i=1,im + if (flg(i) .and. zl(i,k) <= sfcpbl(i)) then + kb1(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + if(pblflg(i)) kb1(i)=min(kb1(i),kpbl(i)) + enddo +! +! re-compute pbl height with the updated thermal +! + do i=1,im + flg(i) = .true. + if(pblflg(i) .and. kb1(i) > 1) then + flg(i) = .false. + rbup(i) = rbsoil(i) +! thermal(i) = thvx(i,kb1(i)) + thermal(i) = thlvx(i,kb1(i)) + kpblx(i) = kb1(i) + hpblx(i) = zl(i,kb1(i)) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i) .and. k > kb1(i)) then + rbdn(i) = rbup(i) + if (tc_pbl == 0) then + 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 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + else if (tc_pbl == 1) then + spdk2 = max((u1(i,k)-u1(i,1))**2+(v1(i,k)-v1(i,1))**2,1.) + & + bfac*ustar(i)**2 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*(zl(i,k)-zl(i,1))/thlvx(i,1))/spdk2 + endif + kpblx(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pblflg(i) .and. kb1(i) > 1) then + k = kpblx(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 + hpblx(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpblx(i) < zi(i,kpblx(i))) kpblx(i)=kpblx(i)-1 + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + endif + enddo +! + if(.not.tte_edmf) then +! +!> - Compute mean tke within pbl for TKE-EDMF +! + do i = 1, im + sumx(i) = 0. + tkemean(i) = 0. + enddo + do k = 1, kmpbl + do i = 1, im + if(k < kpbl(i)) then + dz = zi(i,k+1) - zi(i,k) + tkemean(i) = tkemean(i) + tke(i,k) * dz + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + if(tkemean(i) > 0. .and. sumx(i) > 0.) then + tkemean(i) = tkemean(i) / sumx(i) + endif + enddo +! + endif +! +!> - Compute wind shear term as a sink term for updraft and downdraft +!! velocity +! + kps = max(kmpbl, kmscu) + do k = 2, kps + do i = 1, im + dz = zi(i,k+1) - zi(i,k) + tem = (0.5*(u1(i,k-1)-u1(i,k+1))/dz)**2 + tem1 = tem+(0.5*(v1(i,k-1)-v1(i,k+1))/dz)**2 + wush(i,k) = csmf * sqrt(tem1) + enddo + enddo +! +!> ## Compute Monin-Obukhov similarity parameters +!! - Calculate the Monin-Obukhov nondimensional stability paramter, commonly +!! referred to as \f$\zeta\f$ using the following equation from Businger et al.(1971) \cite businger_et_al_1971 +!! (eqn 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. + 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 +!> - Calculate the nondimensional gradients of momentum and temperature (\f$\phi_m\f$ (phim) and \f$\phi_h\f$(phih)) are calculated using +!! eqns 5 and 6 from Hong and Pan (1996) \cite hong_and_pan_1996 depending on the surface layer stability: +!! - For the unstable and neutral conditions: +!! \f[ +!! \phi_m=(1-16\frac{0.1h}{L})^{-1/4} +!! \phi_h=(1-16\frac{0.1h}{L})^{-1/2} +!! \f] +!! - For the stable regime +!! \f[ +!! \phi_m=\phi_t=(1+5\frac{0.1h}{L}) +!! \f] + zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) + if(sfcflg(i)) then + tem = 1.0 / (1. - aphi16*zol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + tem1 = 1.0 / (1. - aphi16*zol(i)) + phihs(i) = sqrt(tem1) + phims(i) = sqrt(phihs(i)) + else + phim(i) = 1. + aphi5*zol1 + phih(i) = phim(i) + phims(i) = 1. + aphi5*zol(i) + phihs(i) = phims(i) + endif + enddo +! +!> - The \f$z/L\f$ (zol) is used as the stability criterion for the PBL.Currently, +!! strong unstable (convective) PBL for \f$z/L < -0.02\f$ and weakly and moderately +!! unstable PBL for \f$0>z/L>-0.02\f$ +!> - Compute the velocity scale \f$w_s\f$ (wscale) (eqn 22 of Han et al. 2019). It +!! is represented by the value scaled at the top of the surface layer: +!! \f[ +!! w_s=(u_*^3+7\alpha\kappa w_*^3)^{1/3} +!! \f] +!! where \f$u_*\f$ (ustar) is the surface friction velocity,\f$\alpha\f$ is the ratio +!! of the surface layer height to the PBL height (specified as sfcfrac =0.1), +!! \f$\kappa =0.4\f$ is the von Karman constant, and \f$w_*\f$ is the convective velocity +!! scale defined as eqn23 of Han et al.(2019): +!! \f[ +!! w_{*}=[(g/T)\overline{(w'\theta_v^{'})}_0h]^{1/3} +!! \f] + do i=1,im + if(pblflg(i)) then + if(zol(i) < zolcru) then + pcnvflg(i) = .true. + endif + wst3(i) = gotvx(i,1)*sflux(i)*hpbl(i) + wstar(i)= wst3(i)**h1 + ust3(i) = ustar(i)**3. + wscale(i)=(ust3(i)+wfac*vk*wst3(i)*sfcfrac)**h1 + ptem = ustar(i)/aphi5 + wscale(i) = max(wscale(i),ptem) + endif + enddo +! +!> ## The counter-gradient terms for temperature and humidity are calculated. +!! - 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) for use in the mass-flux algorithm. +! + do i = 1,im + if(pcnvflg(i)) then + hgamt(i) = heat(i)/wscale(i) + hgamq(i) = evap(i)/wscale(i) + vpert(i) = hgamt(i) + hgamq(i)*fv*theta(i,1) + vpert(i) = max(vpert(i),0.) + tem = min(cfac*vpert(i),gamcrt) + thermal(i)= thermal(i) + tem + endif + enddo +! +! enhance the pbl height by considering the thermal excess +! (overshoot pbl top) +! + do i=1,im + flg(i) = .true. + if(pcnvflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i) .and. k > kb1(i)) then + rbdn(i) = rbup(i) + if (tc_pbl == 0) then + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + else if (tc_pbl == 1) then + spdk2 = max((u1(i,k)-u1(i,1))**2+(v1(i,k)-v1(i,1))**2,1.) + & + bfac*ustar(i)**2 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*(zl(i,k)-zl(i,1))/thlvx(i,1))/spdk2 + endif + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pcnvflg(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))) then + kpbl(i) = kpbl(i) - 1 + endif + if(kpbl(i) <= 1) then + pcnvflg(i) = .false. + pblflg(i) = .false. + endif + endif + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute tke using tte & ri for TTE-EDMF +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + if(tte_edmf) then +! + do i = 1, im + tem = phims(i) * phims(i) + ris(i) = zol(i) * phihs(i) / tem + ris(i) = max(ris(i), rimin) + enddo + do k = 1, km1 + do i = 1, im + ptem = sfcfrac*hpbl(i) + if (zl(i,k) <= ptem) then + ri = ris(i) + else + if(k == 1) then + tem = gotvx(i,1) * (thlvx(i,1)-thvs(i)) + tem1 = tem / zl(i,1) + tem1 = 0.5 * (tem1 + bf(i,1)) + ptem = max((u1(i,1)**2+v1(i,1)**2), 1.) + ptem1 = ptem / (zl(i,1) * zl(i,1)) + ptem1 = 0.5 * (ptem1 + shr2(i,1)) + ri = max(tem1/ptem1, rimin) + else + tem1 = 0.5 * (bf(i,k-1) + bf(i,k)) + ptem1 = 0.5 * (shr2(i,k-1) + shr2(i,k)) + ri = max(tem1/ptem1, rimin) + endif + endif + if(ri < 0) then + tem = 2. * ri - pr0 + epotte = ri / tem + else + tem = pr0 + 3. * ri + epotte = ri / tem + endif + tke(i,k) = te(i,k) * (1. - epotte) + enddo + enddo + do i=1,im + tke(i,km) = tke(i,km1) + enddo +! +!> - Compute mean tke within pbl for TTE-EDMF +! + do i = 1, im + sumx(i) = 0. + tkemean(i) = 0. + enddo + do k = 1, kmpbl + do i = 1, im + if(k < kpbl(i)) then + dz = zi(i,k+1) - zi(i,k) + tkemean(i) = tkemean(i) + tke(i,k) * dz + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + if(tkemean(i) > 0. .and. sumx(i) > 0.) then + tkemean(i) = tkemean(i) / sumx(i) + endif + enddo +! + endif ! end of if(tte_edmf) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! look for stratocumulus +!> ## Determine whether stratocumulus layers exist and compute quantities +!! - Starting at the PBL top and going downward, if the level is less than 2.5 km +!! and \f$q_l\geq q_{lcr}\f$ then set kcld = k (find the cloud top index in the PBL. +!! If no cloud water above the threshold is hound, \e scuflg is set to F. + 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 + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k <= lcld(i)) then + if(qlx(i,k) >= 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 wihin 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 = kmscu,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 +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> ## Compute components for mass flux mixing by large thermals +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> - If the PBL is convective, the updraft properties are initialized +!! to be the same as the state variables. + 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) + endif + if(scuflg(i)) then + tcdo(i,k) = t1(i,k) + ucdo(i,k) = u1(i,k) + vcdo(i,k) = v1(i,k) + endif + enddo + enddo + do n = 1, ntrac1 + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + qcko(i,k,n) = q1(i,k,n) + endif + if(scuflg(i)) then + qcdo(i,k,n) = q1(i,k,n) + endif + enddo + enddo + enddo +!> - Call mfpbltq(), which is an EDMF parameterization (Siebesma et al.(2007) \cite Siebesma_2007) +!! to take into account nonlocal transport by large eddies. For details of the mfpbltq subroutine, step into its documentation ::mfpbltq + call mfpbltq(im,im,km,kmpbl,ntcw,ntrac1,dt2, + & pcnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, + & gdx,hpbl,kpbl,vpert,buou,wush,tkemean,vez0fun,xmf, + & tcko,qcko,ucko,vcko,xlamue,bl_upfr) +!> - Call mfscuq(), which is a new mass-flux parameterization for +!! stratocumulus-top-induced turbulence mixing. For details of the mfscuq subroutine, step into its documentation ::mfscuq + call mfscuq(im,im,km,kmscu,ntcw,ntrac1,dt2, + & scuflg,zl,zm,q1,t1,u1,v1,plyr,pix, + & thlx,thvx,thlvx,gdx,thetae, + & krad,mrad,radmin,buod,wush,tkemean,vez0fun,xmfd, + & tcdo,qcdo,ucdo,vcdo,xlamde,bl_dnfr) + + if (tc_pbl == 1) then +!> - unify mass fluxes with Cu + do i=1,im + if(zol(i) > -0.5) then + do k = 1, km + xmf(i,k) = 0.0 + end do + end if + end do +!> - taper off MF in high-wind conditions + do i = 1,im + tem = sqrt(u10m(i)**2+v10m(i)**2) + mffac = (1. - MIN(MAX(tem - 20.0, 0.0), 10.0)/10.) + do k = 1, km + xmf(i,k) = xmf(i,k)*mffac + xmfd(i,k) = xmfd(i,k)*mffac + enddo + enddo + endif +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> ## Compute Prandtl number \f$P_r\f$ (prn) and exchange coefficient varying with height + do k = 1, kmpbl + do i = 1, im + if(k < kpbl(i)) then + tem = phih(i)/phim(i) + ptem = sfcfrac*hpbl(i) + tem1 = max(zi(i,k+1)-ptem, 0.) + tem2 = tem1 / (hpbl(i) - ptem) + if(pcnvflg(i)) then + tem = min(tem, pr0) + prn(i,k) = tem + (pr0 - tem) * tem2 + else + tem = max(tem, pr0) + prn(i,k) = tem + endif + prn(i,k) = min(prn(i,k),prmax) + prn(i,k) = max(prn(i,k),prmin) +! + ckz(i,k) = ck0 + (ck1 - ck0) * tem2 + ckz(i,k) = max(min(ckz(i,k), ck0), ck1) + chz(i,k) = ch0 + (ch1 - ch0) * tem2 + chz(i,k) = max(min(chz(i,k), ch0), ch1) +! + endif + enddo + enddo +! +! Above a threshold height (hcrinv), the background vertical +! diffusivities & mixing length +! in the inversion layers are set to much smaller values (xkinv1 & +! rlmn1) +! +! Below the threshold height (hcrinv), the background vertical +! diffusivities & mixing length +! in the inversion layers are increased with increasing roughness +! length & vegetation fraction +! + do k = 1,km1 + do i=1,im + if(zi(i,k+1) > hcrinv) then + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 >= 0.) then + xkzo(i,k) = min(xkzo(i,k), xkinv1) + xkzmo(i,k) = min(xkzmo(i,k), xkinv1) + rlmnz(i,k) = min(rlmnz(i,k), rlmn1) + endif + else + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 > 0.) then + ptem = xkzo(i,k) * zvfun(i) + xkzo(i,k) = min(max(ptem, xkinv2), xkzo(i,k)) + ptem = xkzmo(i,k) * zvfun(i) + xkzmo(i,k) = min(max(ptem, xkinv2), xkzmo(i,k)) + ptem = rlmnz(i,k) * zvfun(i) + rlmnz(i,k) = min(max(ptem, rlmn2), rlmnz(i,k)) + endif + endif + enddo + enddo + do k = 2,km1 + do i=1,im + rlmnz(i,k) = 0.5 * (rlmnz(i,k-1) + rlmnz(i,k)) + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> ## Compute an asymtotic mixing length +! + do k = 1, km1 + do i = 1, im + zlup = 0.0 + mlenflg = .true. + e2(i,k) = max(2.*tke(i,k), 0.001) + do n = k, km1 + if(mlenflg) then + dz = zl(i,n+1) - zl(i,n) + tem1 = 2.*gotvx(i,n+1)*(thvx(i,k)-thvx(i,n+1)) + tem2 = cs0*sqrt(e2(i,n))*sqrt(shr2(i,n)) + e2(i,n+1) = e2(i,n) + (tem1 - tem2) * dz + zlup = zlup + dz + if(e2(i,n+1) < 0.) then + ptem = e2(i,n+1) / (e2(i,n+1) - e2(i,n)) + zlup = zlup - ptem * dz + zlup = max(zlup, 0.) + mlenflg = .false. + endif + endif + enddo + zldn = 0.0 + mlenflg = .true. + do n = k, 1, -1 + if(mlenflg) then + if(n == 1) then + dz = zl(i,1) + tem = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem1 = 2.*gotvx(i,n)*(tem-thvx(i,k)) + tem2 = ustar(i)*phims(i)/(vk*dz) + tem2 = cs0*sqrt(e2(i,n))*tem2 + e2(i,n-1) = e2(i,n) + (tem1 - tem2) * dz + else + dz = zl(i,n) - zl(i,n-1) + tem1 = 2.*gotvx(i,n-1)*(thvx(i,n-1)-thvx(i,k)) + tem2 = cs0*sqrt(e2(i,n))*sqrt(shr2(i,n-1)) + e2(i,n-1) = e2(i,n) + (tem1 - tem2) * dz + endif + zldn = zldn + dz + if(e2(i,n-1) < 0.) then + ptem = e2(i,n-1) / (e2(i,n-1) - e2(i,n)) + zldn = zldn - ptem * dz + zldn = max(zldn, 0.) + mlenflg = .false. + endif + endif + enddo +! + tem = 0.5 * (zi(i,k+1)-zi(i,k)) + tem1 = min(tem, rlmnz(i,k)) +!> - Following Bougeault and Lacarrere(1989), the characteristic length +!! scale (\f$l_2\f$) (eqn 10 in Han et al.(2019) \cite Han_2019) is given by: +!!\f[ +!! l_2=min(l_{up},l_{down}) +!!\f] +!! and dissipation length scale \f$l_d\f$ is given by: +!!\f[ +!! l_d=(l_{up}l_{down})^{1/2} +!!\f] +!! where \f$l_{up}\f$ and \f$l_{down}\f$ are the distances that a parcel +!! having an initial TKE can travel upward and downward before being stopped +!! by buoyancy effects. +! +! Following Rodier et. al (2017), environmental wind shear effect on +! mixing length was included. +! + ptem2 = min(zlup,zldn) + rlam(i,k) = elmfac * ptem2 + rlam(i,k) = max(rlam(i,k), tem1) + rlam(i,k) = min(rlam(i,k), rlmx) +! + ptem2 = sqrt(zlup*zldn) + ele(i,k) = elefac * ptem2 + ele(i,k) = max(ele(i,k), tem1) + elmh(i,k)= elmhfac * ele(i,k) + ele(i,k) = min(ele(i,k), elmx) + elmh(i,k)= min(elmh(i,k), elmhmx) +! + enddo + enddo +!> - Compute the surface layer length scale (\f$l_1\f$) following +!! Nakanishi (2001) \cite Nakanish_2001 (eqn 9 of Han et al.(2019) \cite Han_2019) + do k = 1, km1 + do i = 1, im + tem = vk * zl(i,k) + if (zol(i) < 0.) then + ptem = 1. - 100. * zol(i) + ptem1 = ptem**0.2 + zk = tem * ptem1 + elseif (zol(i) >= 1.) then + zk = tem / 3.7 + else + ptem = 1. + 2.7 * zol(i) + zk = tem / ptem + endif + + if (tc_pbl == 0) then + elm(i,k) = zk*rlam(i,k)/(rlam(i,k)+zk) +!> - If sfc_rlm=1, use zk for elm within surface layer + if ( sfc_rlm == 1 ) then + if ( sfcflg(i) .and. + & zl(i,k) < min(100.0,hpbl(i)*0.05) ) elm(i,k)=zk + endif + else if (tc_pbl == 1) then + ! new blending method for mixing length + elm(i,k) = sqrt( 1.0/( 1.0/(zk**2)+1.0/(rlam(i,k)**2) ) ) + endif + +! + if(k == 1) elm(i,k)=zk +! + dz = zi(i,k+1) - zi(i,k) + tem = max(gdx(i),dz) + elm(i,k) = min(elm(i,k), tem) + + if (tc_pbl == 0) then + ele(i,k) = min(ele(i,k), tem) + else if (tc_pbl == 1) then + ele(i,k) = elm(i,k) + endif +! + enddo + enddo + do i = 1, im + elm(i,km) = elm(i,km1) + ele(i,km) = ele(i,km1) + elmh(i,km)= elmh(i,km1) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> ## Compute eddy diffusivities +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + if(tte_edmf) then +! + do k = 1, km1 + do i = 1, im + ptem = sfcfrac*hpbl(i) + if (zi(i,k+1) <= ptem) then + ri = ris(i) + else + ri = max(bf(i,k)/shr2(i,k),rimin) + endif + if(ri < 0) then + tem = 2. * ri - pr0 + epotte = ri / tem + else + tem = pr0 + 3. * ri + epotte = ri / tem + endif + tkeh(i,k) = tteh(i,k) * (1. - epotte) + tesq(i,k) = tkeh(i,k) / sqrt(tteh(i,k)) + enddo + enddo +! + else +! + do k = 1, km1 + do i = 1, im + tesq(i,k) = sqrt(tkeh(i,k)) + enddo + enddo +! + endif +! + do k = 1, km1 + do i = 1, im + tem = 0.5 * (elm(i,k) + elm(i,k+1)) + tem = tem * tesq(i,k) + ri = max(bf(i,k)/shr2(i,k),rimin) + if(k < kpbl(i)) then + if(pcnvflg(i)) then + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) + else + if(ri < 0.) then ! unstable regime + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) + else ! stable regime + dkt(i,k) = chz(i,k) * tem + dku(i,k) = dkt(i,k) * prn(i,k) + endif + endif + else + if(ri < 0.) then ! unstable regime + dku(i,k) = ck1 * tem + dkt(i,k) = rchck * dku(i,k) + else ! stable regime + dkt(i,k) = ch1 * tem + prnum = pr0 + 2.1 * ri + prnum = min(prnum,prmax) + dku(i,k) = dkt(i,k) * prnum + endif + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + if(tte_edmf) then + tem1 = ck0 * tem + else + tem1 = ckz(i,k) * tem + endif + ptem1 = tem1 / prscu + dku(i,k) = max(dku(i,k), tem1) + dkt(i,k) = max(dkt(i,k), ptem1) + endif + endif +! + dkq(i,k) = prtke * dkt(i,k) +! + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dkq(i,k) = min(dkq(i,k),dkmax) + dkq(i,k) = max(dkq(i,k),xkzo(i,k)) + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) +! + enddo + enddo +! +!The following is for SA-3D-TKE + if(sa3dtke) then +! 1. compute LES component of km, kh, and kq (Deardorff 1980) +! calculate thetal + do k=1,km + do i=1,im + pix(i,k) = psk(i) / prslk(i,k) + theta(i,k) = t1(i,k) * pix(i,k) + tem=theta(i,k)/t1(i,k) + if(ntiw > 0) then + tem1=max(q1(i,k,ntcw),qlmin)+ + & max(q1(i,k,ntiw)+q1(i,k,5)+q1(i,k,6),qlmin) + thetal(i,k)=theta(i,k)-(hvap+hfus)/cp*tem*tem1 + else + tem1=max(q1(i,k,ntcw),qlmin) + thetal(i,k)=theta(i,k)-hvap/cp*tem*tem1 + endif + enddo + enddo + + do k=1,km + do i=1,im + dku_les(i,k) = 0. + dkt_les(i,k) = 0. + dkq_les(i,k) = 0. + enddo + enddo +! +! eddy diffusivities at model interface (zm level) in LES scale +! + do k = 1, km1 + do i = 1, im + tem=gotvx(i,k)*(thetal(i,k+1)-thetal(i,k))*rdzt(i,k) + dz = zl(i,k+1) - zl(i,k) + tem1=(garea(i)*dz)**h1 +! calculate LES mixing length + if(tem > 0.0) then + elm_les=0.76*sqrt(tke(i,k))/sqrt(tem) + elm_les=min(elm_les,tem1) + else + elm_les=tem1 + endif +! calculate km, kh, and kq for LES + dku_les(i,k)=0.1*elm_les*sqrt(tkeh(i,k)) + dkt_les(i,k)=(1.0+2.0*elm_les/tem1)*dku_les(i,k) + dkq_les(i,k)=dkt_les(i,k) + dku_les(i,k) = min(dku_les(i,k),dkmaxles) + dkt_les(i,k) = min(dkt_les(i,k),dkmaxles) + dkq_les(i,k) = min(dkq_les(i,k),dkmaxles) + enddo + enddo +! +! calculate blending coefficients for km, kt, kq, and nonlocal mixing +! finding scale of large eddies from TKE + do i=1,im + tkemax(i) = tke(i,1) + ktkemax(i) = 1 + enddo + do k = 2, kmpbl + do i = 1, im + if(tke(i,k) > tkemax(i)) then + tkemax(i) = tke(i,k) + ktkemax(i) = k + endif + enddo + enddo + do i=1,im + flg(i) = .true. + scl(i) = 0. + if(zl(i,ktkemax(i)) > sclmax) then + flg(i) = .false. + scl(i) = sclmin + endif + enddo + do k = 1, kmpbl + do i = 1, im + if(flg(i) .and. k > ktkemax(i)) then + scl(i) = zl(i,k) + tem = 0.5*tkemax(i) + if(tke(i,k) < tem) flg(i) = .false. + endif + enddo + enddo + do i=1,im + scl(i)=max(scl(i), sclmin) + scl(i)=min(scl(i), sclmax) + scl(i)=max(scl(i), hpbl(i)) + pfdx(i)=gdx(i)/scl(i) + enddo +! + do i = 1, im +! partition function for local fluxes + pfl(i)=cpl1*(pfdx(i)**2+cpl2*pfdx(i)**0.5-cpl3)/ + & (pfdx(i)**2+cpl4*pfdx(i)**0.5+cpl5)+cpl6 + pfl(i)=min(max(pfl(i),0.0),1.0) +! partition function for TKE + pftke(i)=(pfdx(i)**2+cptke1*pfdx(i)**(2./3.))/ + & (pfdx(i)**2+cptke2*pfdx(i)**(2./3.)+cptke3) + pftke(i)=min(max(pftke(i),0.0),1.0) + enddo +! +! blending LES and MS components of vertical km,kt, and kq +! + do k = 1,km1 + do i=1,im + dkq(i,k)=(1.0-pfl(i))*dkq_les(i,k)+pfl(i)*dkq(i,k) + dkt(i,k)=(1.0-pfl(i))*dkt_les(i,k)+pfl(i)*dkt(i,k) + dku(i,k)=(1.0-pfl(i))*dku_les(i,k)+pfl(i)*dku(i,k) + enddo + enddo +! +! 2. compute MS horizontal km +! + do k = 1, km + do i = 1, im + dku_h(i,k)=ckh*elmh(i,k)*sqrt(tke(i,k)) + dkq_h(i,k)=dku_h(i,k) + enddo + enddo +! +! eddy diffusivities at model layer (zl level) in LES scale +! + do k = 1, km1 + do i = 1, im + if(k > 1) then + dz = zl(i,k+1) - zl(i,k-1) + tem=gotvx(i,k)*(thetal(i,k+1)-thetal(i,k-1))/dz + else + dz = zl(i,k+1) + tem=gotvx(i,k)*(thetal(i,k+1)-thvs(i))/dz + endif + dz = zi(i,k+1) - zi(i,k) + tem1=(garea(i)*dz)**h1 +! calculate LES mixing length + if(tem > 0.0) then + elm_les=0.76*sqrt(tke(i,k))/sqrt(tem) + elm_les=min(elm_les,tem1) + else + elm_les=tem1 + endif + ele_les(i,k)=elm_les +! calculate km, kh, and kq for LES + dku_les(i,k)=0.1*elm_les*sqrt(tke(i,k)) + dkq_les(i,k)=(1.0+2.0*elm_les/tem1)*dku_les(i,k) + dku_les(i,k) = min(dku_les(i,k),dkmaxles) + dkq_les(i,k) = min(dkq_les(i,k),dkmaxles) + enddo + enddo +! + do k = 1,km1 + do i=1,im + dku_h(i,k)=(1.0-pfl(i))*dku_les(i,k)+pfl(i)*dku_h(i,k) + dkq_h(i,k)=(1.0-pfl(i))*dkq_les(i,k)+pfl(i)*dkq_h(i,k) + enddo + enddo + do i = 1, im + dku_h(i,km)=dku_h(i,km1) + dkq_h(i,km)=dkq_h(i,km1) + enddo +! + endif !sa3dtke + +!PCC_CANOPY------------------------------------ + kount=0 !IVAI + if (do_canopy .and. cplaqm) then + +!IVAI +! Output 3D pbl diags +! aux3d(:,:,5) = dku(:,:) ! Out +! aux3d(:,:,3) = dkt(:,:) ! Out + +! 3-Layer Sub-Canopy effect + if (present(dku_can)) dku(:,1:km) = dku_can(:,1:km) + if (present(dkt_can)) then + dkt(:,1:km) = dkt_can(:,1:km) + dkq(:,1:km-1) = prtke * dkt_can(:,1:km-1) + endif + + endif !do_canopy .and. cplaqm + +!> ## Compute TKE. +!! - Compute a minimum TKE deduced from background diffusivity for momentum. +! + do k = 1, km1 + do i = 1, im + if(k == 1) then + tem = ckz(i,1) + tem1 = 0.5 * xkzmo(i,1) + else + tem = 0.5 * (ckz(i,k-1) + ckz(i,k)) + tem1 = 0.5 * (xkzmo(i,k-1) + xkzmo(i,k)) + endif + ptem = tem1 / (tem * elm(i,k)) + tkmnz(i,k) = ptem * ptem + tkmnz(i,k) = min(tkmnz(i,k), tkbmx) + tkmnz(i,k) = max(tkmnz(i,k), tkmin) + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> - Compute buoyancy and shear productions of TKE or TTE +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, km1 + do i = 1, im + if (k == 1) then + tem = -dkt(i,1) * bf(i,1) +! if(pcnvflg(i)) then +! ptem1 = xmf(i,1) * buou(i,1) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem2 = xmfd(i,1) * buod(i,1) + else + ptem2 = 0. + endif + tem = tem + ptem1 + ptem2 + buop = 0.5 * (gotvx(i,1) * sflux(i) + tem) +! + if(sa3dtke) then + tem = 2. * dku_h(i,1) + tem1 = dku(i,1)*def_1(i,1)+tem*def_2(i,1) + else + tem1 = dku(i,1) * shr2(i,1) + endif +! + tem = (u1(i,2)-u1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem1 = 0.5 * ptem * (u1(i,2)-ucko(i,2)) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = ucdo(i,1)+ucdo(i,2)-u1(i,1)-u1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem1 = ptem1 + ptem +! + tem = (v1(i,2)-v1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem2 = 0.5 * ptem * (v1(i,2)-vcko(i,2)) +! else + ptem2 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = vcdo(i,1)+vcdo(i,2)-v1(i,1)-v1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem2 = ptem2 + ptem +! + tem2 = stress(i)*ustar(i)*phims(i)/(vk*zl(i,1)) + shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2) + else + tem1 = -dkt(i,k-1) * bf(i,k-1) + tem2 = -dkt(i,k) * bf(i,k) + tem = 0.5 * (tem1 + tem2) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = 0.5 * (xmf(i,k-1) + xmf(i,k)) + ptem1 = ptem * buou(i,k) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = 0.5 * (xmfd(i,k-1) + xmfd(i,k)) + ptem2 = ptem0 * buod(i,k) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + buop = tem + ptem1 + ptem2 +! + if(sa3dtke) then +! obtaining 3d shear production from dycore + tem2 = 2.*dku_h(i,k) + tem1 = dku(i,k-1)*def_1(i,k-1) + tem2 = dku(i,k)*def_1(i,k)+tem2*def_2(i,k) + else + tem1 = dku(i,k-1) * shr2(i,k-1) + tem2 = dku(i,k) * shr2(i,k) + endif + tem = 0.5 * (tem1 + tem2) + tem1 = (u1(i,k+1)-u1(i,k))*rdzt(i,k) + tem2 = (u1(i,k)-u1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (u1(i,k)-ucko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (ucdo(i,k)-u1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = tem + ptem1 + ptem2 + tem1 = (v1(i,k+1)-v1(i,k))*rdzt(i,k) + tem2 = (v1(i,k)-v1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (v1(i,k)-vcko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (vcdo(i,k)-v1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = shrp + ptem1 + ptem2 + endif + if(tte_edmf) then + if(buop > 0.) then + prod(i,k) = 2. * buop + shrp + else + prod(i,k) = shrp + endif + else + prod(i,k) = buop + shrp + endif + enddo + enddo +! +!---------------------------------------------------------------------- +!> - First predict te due to te production & dissipation(diss) +! + if(sa3dtke) then +!The following is for SA-3D-TKE + dtn = dt2 / float(ndt) + do n = 1, ndt + do k = 1,km1 + do i=1,im + tem = sqrt(te(i,k)) +! calculating 3D TKE transport and pressure correlation + ptem1 = ce0 / ele(i,k) + dz = zi(i,k+1) - zi(i,k) + tem1=(garea(i)*dz)**h1 + tem2=0.19+0.51*ele_les(i,k)/tem1 + ptem2= tem2 / ele_les(i,k) + ptem=(1.0-pftke(i))*ptem2+pftke(i)*ptem1 + disste = ptem * te(i,k) * tem + tem1 = prod(i,k) + te(i,k) / dtn + disste=max(min(disste, tem1), 0.) + if(.not. tte_edmf) diss(i,k) = disste +! tem=2.0*def_3(i,k) + tem=def_3(i,k) +! tem=min(tem,1.0) + te(i,k) = te(i,k) + dtn * (prod(i,k)-disste+tem) +! te(i,k) = max(te(i,k), tkmin) + te(i,k) = max(te(i,k), tkmnz(i,k)) + enddo + enddo + enddo + else + dtn = dt2 / float(ndt) + do n = 1, ndt + do k = 1,km1 + do i=1,im + tem = sqrt(te(i,k)) + ptem = ce0 / ele(i,k) + disste = ptem * te(i,k) * tem + tem1 = prod(i,k) + te(i,k) / dtn + disste = max(min(disste, tem1), 0.) + if(.not. tte_edmf) diss(i,k) = disste + te(i,k) = te(i,k) + dtn * (prod(i,k)-disste) + te(i,k) = max(te(i,k), tkmnz(i,k)) +! te(i,k) = max(te(i,k), tkmin) + enddo + enddo + enddo + endif !sa3dtke +! +! TKE dissipation for dissipative heating computation in TTE-EDMF +! + if(tte_edmf) then + do k = 1, km1 + do i = 1, im + tem = sqrt(tke(i,k)) + if(sa3dtke) then + ptem1 = ce0 / ele(i,k) + dz = zi(i,k+1) - zi(i,k) + tem1=(garea(i)*dz)**h1 + tem2=0.19+0.51*ele_les(i,k)/tem1 + ptem2= tem2 / ele_les(i,k) + ptem=(1.0-pftke(i))*ptem2+pftke(i)*ptem1 + diss(i,k) = ptem * tke(i,k) * tem + else + ptem = ce0 / ele(i,k) + diss(i,k) = ptem * tke(i,k) * tem + endif + enddo + enddo + endif +! +!> - Compute updraft & downdraft properties for TKE or TTE +! + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + qcko(i,k,ntke) = te(i,k) + endif + if(scuflg(i)) then + qcdo(i,k,ntke) = te(i,k) + endif + enddo + enddo + do k = 2, kmpbl + do i = 1, im + if (pcnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem + qcko(i,k,ntke)=((1.-tem)*qcko(i,k-1,ntke)+tem* + & (te(i,k)+te(i,k-1)))/factor + endif + enddo + enddo + do k = kmscu, 1, -1 + do i = 1, im + if (scuflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem + qcdo(i,k,ntke)=((1.-tem)*qcdo(i,k+1,ntke)+tem* + & (te(i,k)+te(i,k+1)))/factor + endif + endif + enddo + enddo +! +!-------------------------------------------------------- +! compute variables for TVD flux-limiter scheme +! on environmental subsidence and uplifting +! + kps = max(kmpbl, kmscu) +! +! for moisture and tracers including hydrometeors +! + do n=1,ntrac1 + do k=1,kps + do i=1,im + qh(i,k,n) = 0.5 * (q1(i,k,n)+q1(i,k+1,n)) + enddo + enddo + do k=1,kps + do i=1,im + q_diff(i,k,n) = q1(i,k,n) - q1(i,k+1,n) + enddo + enddo + do i=1,im + if(q1(i,1,n) >= 0.) then + q_diff(i,0,n) = max(0.,2.*q1(i,1,n)-q1(i,2,n))- + & q1(i,1,n) + else + q_diff(i,0,n) = min(0.,2.*q1(i,1,n)-q1(i,2,n))- + & q1(i,1,n) + endif + enddo + enddo +! + do n = 1, ntrac1 +! + do k = 1, kps + do i = 1, im + kmx = max(kpbl(i), krad(i)) + q_half(i,k,n) = qh(i,k,n) + if((pcnvflg(i) .or. scuflg(i)) .and. k < kmx) then + tem = 0. + if(pcnvflg(i) .and. k < kpbl(i)) then + tem = xmf(i,k) + endif + if(scuflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + tem = tem - xmfd(i,k) + endif + if(tem > 0.) then + rrkp = 0. + if(abs(q_diff(i,k,n)) > 1.e-22) + & rrkp = q_diff(i,k+1,n) / q_diff(i,k,n) + phkp = (rrkp+abs(rrkp)) / (1.+abs(rrkp)) + q_half(i,k,n) = q1(i,k+1,n) + + & phkp*(qh(i,k,n)-q1(i,k+1,n)) + elseif (tem < 0.) then + rrkp = 0. + if(abs(q_diff(i,k,n)) > 1.e-22) + & rrkp = q_diff(i,k-1,n) / q_diff(i,k,n) + phkp = (rrkp+abs(rrkp)) / (1.+abs(rrkp)) + q_half(i,k,n) = q1(i,k,n) + + & phkp*(qh(i,k,n)-q1(i,k,n)) + endif + endif + enddo + enddo +! + enddo +! +! for TKE or TTE +! + do k=1,kps + do i=1,im + tei(i,k) = 0.5 * (te(i,k)+te(i,k+1)) + enddo + enddo + + do k=1,kps + do i=1,im + e_diff(i,k) = te(i,k) - te(i,k+1) + enddo + enddo + do i=1,im + if(te(i,1) >= 0.) then + e_diff(i,0) = max(0.,2.*te(i,1)-te(i,2))- + & te(i,1) + else + e_diff(i,0) = min(0.,2.*te(i,1)-te(i,2))- + & te(i,1) + endif + enddo +! + do k = 1, kps + do i = 1, im + kmx = max(kpbl(i), krad(i)) + e_half(i,k) = tei(i,k) + if((pcnvflg(i) .or. scuflg(i)) .and. (k < kmx)) then + tem = 0. + if(pcnvflg(i) .and. k < kpbl(i)) then + tem = xmf(i,k) + endif + if(scuflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + tem = tem - xmfd(i,k) + endif + if(tem > 0.) then + rrkp = 0. + if(abs(e_diff(i,k)) > 1.e-22) + & rrkp = e_diff(i,k+1) / e_diff(i,k) + phkp = (rrkp+abs(rrkp)) / (1.+abs(rrkp)) + e_half(i,k) = te(i,k+1) + + & phkp*(tei(i,k)-te(i,k+1)) + elseif (tem < 0.) then + rrkp = 0. + if(abs(e_diff(i,k)) > 1.e-22) + & rrkp = e_diff(i,k-1) / e_diff(i,k) + phkp = (rrkp+abs(rrkp)) / (1.+abs(rrkp)) + e_half(i,k) = te(i,k) + + & phkp*(tei(i,k)-te(i,k)) + endif + endif + enddo + enddo +! +!---------------------------------------------------------------------- +!> - Compute tridiagonal matrix elements for TKE or TTE +! + do i=1,im + ad(i,1) = 1.0 + f1(i,1) = te(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 * dkq(i,k) * rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ptem = qcko(i,k,ntke) + qcko(i,k+1,ntke) + f1(i,k) = f1(i,k) - ptem * ptem1 + f1(i,k+1) = te(i,k+1) + ptem * ptem2 + else + f1(i,k+1) = te(i,k+1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ptem = qcdo(i,k,ntke) + qcdo(i,k+1,ntke) + f1(i,k) = f1(i,k) + ptem * ptem1 + f1(i,k+1) = f1(i,k+1) - ptem * ptem2 + endif + endif +! + kmx = max(kpbl(i), krad(i)) + if((pcnvflg(i) .or. scuflg(i)) .and. (k < kmx)) then + ptem = tem2 * (xmf(i,k) - xmfd(i,k)) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + f1(i,k) = f1(i,k) + e_half(i,k) * ptem1 + f1(i,k+1) = f1(i,k+1) - e_half(i,k) * ptem2 + endif +! + enddo + enddo +c +!> - Call tridit() to solve tridiagonal problem for TKE +c + call tridit(im,km,1,al,ad,au,f1,au,f1) +! +! Negative TKE or TTE are set to zero after borrowing it from positive +! values within the mass-flux transport layers +! + do i = 1,im + tsumn(i) = 0. + tsump(i) = 0. + rtnp(i) = 1. + enddo + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + tem = f1(i,k) * del(i,k) * gravi + if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem + endif + enddo + enddo + do i = 1,im + if(pcnvflg(i) .or. scuflg(i)) then + if(tsump(i) > 0. .and. tsumn(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + rtnp(i) = tsumn(i) / tsump(i) + else + rtnp(i) = tsump(i) / tsumn(i) + endif + endif + endif + enddo + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + if(rtnp(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + if(f1(i,k) < 0.) f1(i,k) = 0. + if(f1(i,k) > 0.) f1(i,k) = (1.+rtnp(i))*f1(i,k) + else + if(f1(i,k) < 0.) f1(i,k) = (1.+rtnp(i))*f1(i,k) + if(f1(i,k) > 0.) f1(i,k) = 0. + endif + endif + endif + enddo + enddo +! +! To remove negative TKEs or TTEs which were leaked out of the mass-flux transport layers +! by eddy diffusion or potential negative TKEs or TTEs from the diffusion scheme, +! positive TKEs or TTEs are borrowed again now from the entire layers +! + do i = 1,im + tsumn(i) = 0. + tsump(i) = 0. + rtnp(i) = 1. + enddo + do k = 1,km + do i = 1,im + tem = f1(i,k) * del(i,k) * gravi + if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem + enddo + enddo + do i = 1,im + if(tsump(i) > 0. .and. tsumn(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + rtnp(i) = tsumn(i) / tsump(i) + else + rtnp(i) = tsump(i) / tsumn(i) + endif + endif + enddo + do k = 1,km + do i = 1,im + if(rtnp(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + if(f1(i,k) < 0.) f1(i,k) = 0. + if(f1(i,k) > 0.) f1(i,k) = (1.+rtnp(i))*f1(i,k) + else + if(f1(i,k) < 0.) f1(i,k) = (1.+rtnp(i))*f1(i,k) + if(f1(i,k) > 0.) f1(i,k) = 0. + endif + endif + enddo + enddo +c +!> - Recover the tendency of TKE or TTE +c + do k = 1,km + do i = 1,im +! f1(i,k) = max(f1(i,k), tkmin) + qtend = (f1(i,k)-q1(i,k,ntke))*rdt + rtg(i,k,ntke) = rtg(i,k,ntke)+qtend + enddo + enddo + if(ldiag3d .and. present(dtend)) then + idtend = dtidx(ntke+100,index_of_process_pbl) + if(idtend>0) then + dtend(1:im,1:km,idtend) = dtend(1:im,1:km,idtend) + + & (f1(1:im,1:km)-q1(1:im,1:km,ntke))*rdt + endif + endif +c +!> ## Compute tridiagonal matrix elements for heat and moisture +c + do i=1,im + ad(i,1) = 1. + f1(i,1) = t1(i,1) + dtdz1(i) * heat(i) + f2(i,1) = q1(i,1,1) + dtdz1(i) * evap(i) + enddo + if(ntrac1 >= 2) then + do n = 2, ntrac1 + is = (n-1) * km + do i = 1, im + f2(i,1+is) = q1(i,1,n) + enddo + enddo + endif +c + 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 + dsdzt = tem1 * gocp + if (use_lpt > 0) then + dsdzt = dsdzt-tem1*elocp*(qliq(i,k+1)-qliq(i,k))*rdz + & -(1+0.33/2.5)*tem1*elocp*(qice(i,k+1)-qice(i,k))*rdz + endif + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = t1(i,k) + t1(i,k+1) + ptem = tcko(i,k) + tcko(i,k+1) + f1(i,k) = f1(i,k)+dtodsd*dsdzt-(ptem-tem)*ptem1 + f1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt+(ptem-tem)*ptem2 + ptem = qcko(i,k,1) + qcko(i,k+1,1) + f2(i,k) = f2(i,k) - ptem * ptem1 + f2(i,k+1) = q1(i,k+1,1) + ptem * ptem2 + else + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + f2(i,k+1) = q1(i,k+1,1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ptem = tcdo(i,k) + tcdo(i,k+1) + tem = t1(i,k) + t1(i,k+1) + f1(i,k) = f1(i,k) + (ptem - tem) * ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) * ptem2 + ptem = qcdo(i,k,1) + qcdo(i,k+1,1) + f2(i,k) = f2(i,k) + ptem * ptem1 + f2(i,k+1) = f2(i,k+1) - ptem * ptem2 + endif + endif +! + kmx = max(kpbl(i), krad(i)) + if((pcnvflg(i) .or. scuflg(i)) .and. (k < kmx)) then + ptem = tem2 * (xmf(i,k) - xmfd(i,k)) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + f2(i,k) = f2(i,k) + q_half(i,k,1) * ptem1 + f2(i,k+1) = f2(i,k+1) - q_half(i,k,1) * ptem2 + endif +! + enddo + enddo +! + if(ntrac1 >= 2) then + do n = 2, ntrac1 + is = (n-1) * km + 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) + tem2 = dsig * rdzt(i,k) +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ptem = qcko(i,k,n) + qcko(i,k+1,n) + f2(i,k+is) = f2(i,k+is) - ptem * ptem1 + f2(i,k+1+is)= q1(i,k+1,n) + ptem * ptem2 + else + f2(i,k+1+is) = q1(i,k+1,n) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ptem = qcdo(i,k,n) + qcdo(i,k+1,n) + f2(i,k+is) = f2(i,k+is) + ptem * ptem1 + f2(i,k+1+is)= f2(i,k+1+is) - ptem * ptem2 + endif + endif +! + kmx = max(kpbl(i), krad(i)) + if((pcnvflg(i) .or. scuflg(i)) .and. (k < kmx)) then + ptem = tem2 * (xmf(i,k) - xmfd(i,k)) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + f2(i,k+is) = f2(i,k+is) + q_half(i,k,n) * ptem1 + f2(i,k+1+is) = f2(i,k+1+is) - q_half(i,k,n) * ptem2 + endif +! + enddo + enddo + enddo + endif +c +!> - Call tridin() to solve tridiagonal problem for heat and moisture +c + call tridin(im,km,ntrac1,al,ad,au,f1,f2,au,f1,f2) +! +! Negative moisture is set to zero after borrowing it from +! positive values within the mass-flux transport layers +! + do i = 1,im + tsumn(i) = 0. + tsump(i) = 0. + rtnp(i) = 1. + enddo + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + tem = f2(i,k) * del(i,k) * gravi + if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k) > 0.) tsump(i) = tsump(i) + tem + endif + enddo + enddo + do i = 1,im + if(pcnvflg(i) .or. scuflg(i)) then + if(tsump(i) > 0. .and. tsumn(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + rtnp(i) = tsumn(i) / tsump(i) + else + rtnp(i) = tsump(i) / tsumn(i) + endif + endif + endif + enddo + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + if(rtnp(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + if(f2(i,k) < 0.) f2(i,k) = 0. + if(f2(i,k) > 0.) f2(i,k) = (1.+rtnp(i))*f2(i,k) + else + if(f2(i,k) < 0.) f2(i,k) = (1.+rtnp(i))*f2(i,k) + if(f2(i,k) > 0.) f2(i,k) = 0. + endif + endif + endif + enddo + enddo +! +! To remove negative moistures which were leaked out of the mass-flux transport layers +! by eddy diffusion or potential negative moistures from the diffusion scheme +! especially due to downward surface latent heat flux during nighttime, +! positive moistures are borrowed again now from the entire layers +! + do i = 1,im + tsumn(i) = 0. + tsump(i) = 0. + rtnp(i) = 1. + enddo + do k = 1,km + do i = 1,im + tem = f2(i,k) * del(i,k) * gravi + if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k) > 0.) tsump(i) = tsump(i) + tem + enddo + enddo + do i = 1,im + if(tsump(i) > 0. .and. tsumn(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + rtnp(i) = tsumn(i) / tsump(i) + else + rtnp(i) = tsump(i) / tsumn(i) + endif + endif + enddo + do k = 1,km + do i = 1,im + if(rtnp(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + if(f2(i,k) < 0.) f2(i,k) = 0. + if(f2(i,k) > 0.) f2(i,k) = (1.+rtnp(i))*f2(i,k) + else + if(f2(i,k) < 0.) f2(i,k) = (1.+rtnp(i))*f2(i,k) + if(f2(i,k) > 0.) f2(i,k) = 0. + endif + endif + enddo + enddo +! +! Negative hydrometeors & tracers are set to zero after +! borrowing them from positive values within the mass-flux +! transport layers +! +! For the negative liquid water, first borrow water from vapor +! and then borrow it from the other layers if there is still +! negative water +! + if(ntrac1 >= 2) then + is = (ntcw-1) * km + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + if(f2(i,k+is) < 0.) then + tem = f2(i,k) + f2(i,k+is) + if(tem >= 0.0) then + f2(i,k) = tem + f1(i,k) = f1(i,k) - elocp * f2(i,k+is) + f2(i,k+is) = 0. + elseif (f2(i,k) > 0.0) then + f2(i,k+is) = tem + f1(i,k) = f1(i,k) + elocp * f2(i,k) + f2(i,k) = 0. + endif + endif + endif + enddo + enddo + endif +! +! For the negative rain water, first borrow water from vapor +! and then borrow it from the other layers if there is still +! negative water +! + if(ntrac1 >= 2 .and. ntrw > 0) then + is = (ntrw-1) * km + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + if(f2(i,k+is) < 0.) then + tem = f2(i,k) + f2(i,k+is) + if(tem >= 0.0) then + f2(i,k) = tem + f1(i,k) = f1(i,k) - elocp * f2(i,k+is) + f2(i,k+is) = 0. + elseif (f2(i,k) > 0.0) then + f2(i,k+is) = tem + f1(i,k) = f1(i,k) + elocp * f2(i,k) + f2(i,k) = 0. + endif + endif + endif + enddo + enddo + endif +! + if(ntrac1 >= 2) then + do n = 2, ntrac1 + is = (n-1) * km +! + do i = 1,im + tsumn(i) = 0. + tsump(i) = 0. + rtnp(i) = 1. + enddo + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + tem = f2(i,k+is) * del(i,k) * gravi + if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + tem + endif + enddo + enddo + do i = 1,im + if(pcnvflg(i) .or. scuflg(i)) then + if(tsump(i) > 0. .and. tsumn(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + rtnp(i) = tsumn(i) / tsump(i) + else + rtnp(i) = tsump(i) / tsumn(i) + endif + endif + endif + enddo + do k = 1,kps + do i = 1,im + if(pcnvflg(i) .and. scuflg(i)) then + kbx = 1 + kmx = max(kpbl(i), krad(i)) + elseif(pcnvflg(i) .and. .not. scuflg(i)) then + kbx = 1 + kmx = kpbl(i) + elseif(.not. pcnvflg(i) .and. scuflg(i)) then + kbx = mrad(i) + kmx = krad(i) + endif + if((pcnvflg(i) .or. scuflg(i)) .and. + & (k >= kbx .and. k <= kmx)) then + if(rtnp(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + if(f2(i,k+is)<0.) f2(i,k+is)=0. + if(f2(i,k+is)>0.) f2(i,k+is)=(1.+rtnp(i))*f2(i,k+is) + else + if(f2(i,k+is)<0.) f2(i,k+is)=(1.+rtnp(i))*f2(i,k+is) + if(f2(i,k+is)>0.) f2(i,k+is)=0. + endif + endif + endif + enddo + enddo +! +! To remove negative hydrometeors & tracers which were leaked out of the mass-flux transport layers +! by eddy diffusion or potential negative hydrometeors & tracers from the diffusion scheme +! especially due to downward surface fluxes during nighttime, +! positive hydrometeors & tracers are borrowed again now from the entire layers +! + do i = 1,im + tsumn(i) = 0. + tsump(i) = 0. + rtnp(i) = 1. + enddo + do k = 1,km + do i = 1,im + tem = f2(i,k+is) * del(i,k) * gravi + if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + tem + enddo + enddo + do i = 1,im + if(tsump(i) > 0. .and. tsumn(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + rtnp(i) = tsumn(i) / tsump(i) + else + rtnp(i) = tsump(i) / tsumn(i) + endif + endif + enddo + do k = 1,km + do i = 1,im + if(rtnp(i) < 0.) then + if(tsump(i) > abs(tsumn(i))) then + if(f2(i,k+is)<0.) f2(i,k+is)=0. + if(f2(i,k+is)>0.) f2(i,k+is)=(1.+rtnp(i))*f2(i,k+is) + else + if(f2(i,k+is)<0.) f2(i,k+is)=(1.+rtnp(i))*f2(i,k+is) + if(f2(i,k+is)>0.) f2(i,k+is)=0. + endif + endif + enddo + enddo +! + enddo + endif +c +!> - Recover the tendencies of heat and moisture +c + do k = 1,km + do i = 1,im + ttend = (f1(i,k)-t1(i,k))*rdt + qtend = (f2(i,k)-q1(i,k,1))*rdt + tdt(i,k) = tdt(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 +! + do i = 1,im + dtsfc(i) = rho_a(i) * cp * heat(i) + dqsfc(i) = rho_a(i) * hvap * evap(i) + enddo +! + if(ldiag3d .and. .not. gen_tend .and. present(dtend)) then + idtend = dtidx(index_of_temperature,index_of_process_pbl) + if(idtend>=1) then + do k = 1,km + do i = 1,im + ttend = (f1(i,k)-t1(i,k))*rdt + dtend(i,k,idtend) = dtend(i,k,idtend)+ttend*delt + enddo + enddo + endif + ! Send tendencies just for QV; other tracers are below. + idtend = dtidx(100+ntqv,index_of_process_pbl) + if(idtend>=1) then + do k = 1,km + do i = 1,im + qtend = (f2(i,k)-q1(i,k,1))*rdt + dtend(i,k,idtend) = dtend(i,k,idtend)+qtend*delt + enddo + enddo + endif + endif +! + if(ntrac1 >= 2) then + do n = 2, ntrac1 + is = (n-1) * km + do k = 1, km + do i = 1, im + qtend = (f2(i,k+is)-q1(i,k,n))*rdt + rtg(i,k,n) = rtg(i,k,n)+qtend + enddo + enddo + enddo + if(ldiag3d .and. .not. gen_tend .and. present(dtend)) then + ! Send tendencies for all tracers that were selected. + do n = 2, ntrac1 + is = (n-1) * km + idtend = dtidx(n+100,index_of_process_pbl) + if(idtend>=1) then + if(n/=ntke) then + do k = 1, km + do i = 1, im + qtend = (f2(i,k+is)-q1(i,k,n))*rdt + dtend(i,k,idtend) = dtend(i,k,idtend)+qtend*delt + enddo + enddo + endif + endif + enddo + endif +!IVAI +! aux3d(:,:, 7) = rtg(:,:, ntoz) ! ntoz=7 "o3mr" GFS + +! aux3d(:,:, 5) = rtg(:,:, 11) ! n=11 "no3" +! aux3d(:,:, 5) = rtg(:,:, 9 ) ! n=9 "no" +! aux3d(:,:, 3) = rtg(:,:, 10) ! n=10 "o3" +! aux3d(:,:, 1) = rtg(:,:, 8 ) ! n=8 "no2" +!IVAI + endif +! +!> ## Add TKE dissipative heating to temperature tendency +! + if(dspheat) then + do k = 1,km1 + do i = 1,im +! tem = min(diss(i,k), dspmax) +! ttend = tem / cp + ttend = diss(i,k) / cp + tdt(i,k) = tdt(i,k) + dspfac * ttend + enddo + enddo + if(ldiag3d .and. .not. gen_tend .and. present(dtend)) then + idtend = dtidx(index_of_temperature,index_of_process_pbl) + if(idtend>=1) then + do k = 1,km1 + do i = 1,im + ttend = diss(i,k) / cp + dtend(i,k,idtend) = dtend(i,k,idtend)+dspfac*ttend*delt + enddo + enddo + endif + endif + endif +c +!> ## Compute tridiagonal matrix elements for momentum +c + do i=1,im + ad(i,1) = 1.0 + dtdz1(i) * stress(i) / spd1(i) + f1(i,1) = u1(i,1) + f2(i,1) = v1(i,1) + enddo +c + 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 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = u1(i,k) + u1(i,k+1) + ptem = ucko(i,k) + ucko(i,k+1) + f1(i,k) = f1(i,k) - (ptem - tem) * ptem1 + f1(i,k+1) = u1(i,k+1) + (ptem - tem) * ptem2 + tem = v1(i,k) + v1(i,k+1) + ptem = vcko(i,k) + vcko(i,k+1) + f2(i,k) = f2(i,k) - (ptem - tem) * ptem1 + f2(i,k+1) = v1(i,k+1) + (ptem - tem) * ptem2 + else + f1(i,k+1) = u1(i,k+1) + f2(i,k+1) = v1(i,k+1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = u1(i,k) + u1(i,k+1) + ptem = ucdo(i,k) + ucdo(i,k+1) + f1(i,k) = f1(i,k) + (ptem - tem) *ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) *ptem2 + tem = v1(i,k) + v1(i,k+1) + ptem = vcdo(i,k) + vcdo(i,k+1) + f2(i,k) = f2(i,k) + (ptem - tem) * ptem1 + f2(i,k+1) = f2(i,k+1) - (ptem - tem) * ptem2 + endif + endif +! + enddo + enddo +c +!> - Call tridi2() to solve tridiagonal problem for momentum +c + call tridi2(im,km,al,ad,au,f1,f2,au,f1,f2) +c +!> - Recover the tendencies of momentum +c + do k = 1,km + do i = 1,im + utend = (f1(i,k)-u1(i,k))*rdt + vtend = (f2(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 + enddo + enddo + if (use_oceanuv) then + do i = 1,im + spd1_m=sqrt( (u1(i,1)-usfco(i))**2+(v1(i,1)-vsfco(i))**2 ) + dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-usfco(i))/spd1_m + dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-vsfco(i))/spd1_m + enddo + else + do i = 1,im + dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) + dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) + enddo + endif +! + if(ldiag3d .and. .not. gen_tend .and. present(dtend)) then + idtend = dtidx(index_of_x_wind,index_of_process_pbl) + if(idtend>=1) then + do k = 1,km + do i = 1,im + utend = (f1(i,k)-u1(i,k))*rdt + dtend(i,k,idtend) = dtend(i,k,idtend) + utend*delt + enddo + enddo + endif + + idtend = dtidx(index_of_y_wind,index_of_process_pbl) + if(idtend>=1) then + do k = 1,km + do i = 1,im + vtend = (f2(i,k)-v1(i,k))*rdt + dtend(i,k,idtend) = dtend(i,k,idtend) + vtend*delt + enddo + enddo + endif + endif +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> ## Save PBL height for diagnostic purpose +! + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo + if(sa3dtke) then + do k = 1, km + do i = 1, im + dku3d_h(i,k) = dku_h(i,k) ! pass dku3d_h to dyn_core + dku3d_e(i,k) = dkq_h(i,k) ! pass dku3d_e to dyn_core + enddo + enddo + endif !sa3dtke +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end subroutine satmedmfvdifq_can +!> @} + end module satmedmfvdifq_can_mod