diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 834e22db0..2327af72a 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -5,7 +5,7 @@ !>\ingroup gsd_mynn_edmf !> The following references best describe the code within !! Olson et al. (2019, NOAA Technical Memorandum) -!! Nakanishi and Niino (2009 ) \cite NAKANISHI_2009 +!! Nakanishi and Niino (2009) \cite NAKANISHI_2009 MODULE mynnedmf_wrapper contains @@ -13,18 +13,69 @@ MODULE mynnedmf_wrapper !> \section arg_table_mynnedmf_wrapper_init Argument Table !! \htmlinclude mynnedmf_wrapper_init.html !! - subroutine mynnedmf_wrapper_init (do_mynnedmf, lheatstrg, errmsg, errflg) + subroutine mynnedmf_wrapper_init ( & + & con_cp, con_grav, con_rd, con_rv, & + & con_cpv, con_cliq, con_cice, con_rcp, & + & con_XLV, con_XLF, con_p608, con_ep2, & + & con_karman, con_t0c, & + & do_mynnedmf, lheatstrg, & + & errmsg, errflg ) + + use machine, only : kind_phys + use bl_mynn_common + implicit none - logical, intent(in) :: do_mynnedmf - logical, intent(in) :: lheatstrg - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + logical, intent(in) :: do_mynnedmf + logical, intent(in) :: lheatstrg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind=kind_phys),intent(in) :: con_xlv + real(kind=kind_phys),intent(in) :: con_xlf + real(kind=kind_phys),intent(in) :: con_rv + real(kind=kind_phys),intent(in) :: con_rd + real(kind=kind_phys),intent(in) :: con_ep2 + real(kind=kind_phys),intent(in) :: con_grav + real(kind=kind_phys),intent(in) :: con_cp + real(kind=kind_phys),intent(in) :: con_cpv + real(kind=kind_phys),intent(in) :: con_rcp + real(kind=kind_phys),intent(in) :: con_p608 + real(kind=kind_phys),intent(in) :: con_cliq + real(kind=kind_phys),intent(in) :: con_cice + real(kind=kind_phys),intent(in) :: con_karman + real(kind=kind_phys),intent(in) :: con_t0c ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + xlv = con_xlv + xlf = con_xlf + r_v = con_rv + r_d = con_rd + ep_2 = con_ep2 + grav = con_grav + cp = con_cp + cpv = con_cpv + rcp = con_rcp + p608 = con_p608 + cliq = con_cliq + cice = con_cice + karman = con_karman + t0c = con_t0c + + xls = xlv+xlf != 2.85E6 (J/kg) sublimation + rvovrd = r_v/r_d != 1.608 + ep_3 = 1.-ep_2 != 0.378 + gtr = grav/tref + rk = cp/r_d + tv0 = p608*tref + tv1 = (1.+p608)*tref + xlscp = (xlv+xlf)/cp + xlvcp = xlv/cp + g_inv = 1./grav + ! Consistency checks if (.not. do_mynnedmf) then errmsg = 'Logic error: do_mynnedmf = .false.' @@ -50,8 +101,6 @@ end subroutine mynnedmf_wrapper_finalize SUBROUTINE mynnedmf_wrapper_run( & & im,levs, & & flag_init,flag_restart, & - & cp, g, r_d, r_v, cpv, cliq,Cice,& - & rcp, XLV, XLF, EP_1, EP_2, & & lssav, ldiag3d, qdiag3d, & & lsidea, cplflx, & & delt,dtf,dx,zorl, & @@ -84,6 +133,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & recmol, & & qke,qke_adv,Tsq,Qsq,Cov, & & el_pbl,sh3d,exch_h,exch_m, & + & dqke,qwt,qshear,qbuoy,qdiss, & & Pblh,kpbl, & & qc_bl,qi_bl,cldfra_bl, & & edmf_a,edmf_w,edmf_qt, & @@ -91,112 +141,59 @@ SUBROUTINE mynnedmf_wrapper_run( & & sub_thl,sub_sqv,det_thl,det_sqv,& & nupdraft,maxMF,ktop_plume, & & dudt, dvdt, dtdt, & - & dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw - & dqdt_ice_cloud, dqdt_ozone, & ! <=== ntiw, ntoz + & dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw + & dqdt_ice_cloud, dqdt_ozone, & ! <=== ntiw, ntoz & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & ! <=== ntlnc, ntinc - & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, & ! <=== ntwa, ntia + & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc,& ! <=== ntwa, ntia & flag_for_pbl_generic_tend, & & dtend, dtidx, index_of_temperature, & & index_of_x_wind, index_of_y_wind, ntke, & & ntqv, ntcw, ntiw, ntoz, ntlnc, ntinc, ntwa, ntia, & & index_of_process_pbl, htrsw, htrlw, xmu, & - & grav_settling, bl_mynn_tkebudget, bl_mynn_tkeadvect, & - & bl_mynn_cloudpdf, bl_mynn_mixlength, & - & bl_mynn_edmf, bl_mynn_edmf_mom, bl_mynn_edmf_tke, & - & bl_mynn_cloudmix, bl_mynn_mixqt, & - & bl_mynn_output, & + & bl_mynn_tkebudget, bl_mynn_tkeadvect, & + & bl_mynn_cloudpdf, bl_mynn_mixlength, & + & bl_mynn_edmf, & + & bl_mynn_edmf_mom, bl_mynn_edmf_tke, & + & bl_mynn_cloudmix, bl_mynn_mixqt, & + & bl_mynn_output, bl_mynn_closure, & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & & ltaerosol, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: - use machine , only : kind_phys -! use funcphys, only : fpvs - - USE module_bl_mynn, only : mynn_bl_driver + use machine, only: kind_phys + use bl_mynn_common, only: cp, r_d, grav, g_inv, zero, & + xlv, xlvcp, xlscp + use module_bl_mynn, only: mynn_bl_driver !------------------------------------------------------------------- - implicit none + implicit none !------------------------------------------------------------------- -! --- constant parameters: -! real(kind=kind_phys), parameter :: rvovrd = r_v/r_d -! real(kind=kind_phys), parameter :: karman = 0.4 -! real(kind=kind_phys), parameter :: XLS = 2.85E6 -! real(kind=kind_phys), parameter :: p1000mb = 100000. - real(kind=kind_phys), parameter :: SVP1 = 0.6112 -! real(kind=kind_phys), parameter :: SVP2 = 17.67 -! real(kind=kind_phys), parameter :: SVP3 = 29.65 -! real(kind=kind_phys), parameter :: SVPT0 = 273.15 - -! INTEGER , PARAMETER :: param_first_scalar = 1, & -! & p_qc = 2, & -! & p_qr = 0, & -! & p_qi = 2, & -! & p_qs = 0, & -! & p_qg = 0, & -! & p_qnc= 0, & -! & p_qni= 0 - -!------------------------------------------------------------------- -!For WRF: -!------------------------------------------------------------------- -! USE module_model_constants, only: & -! &karman, g, p1000mb, & -! &cp, r_d, r_v, rcp, xlv, xlf, xls, & -! &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & -! &cpv, cliq, cice - -! USE module_state_description, only: param_first_scalar, & -! &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni - -!------------------------------------------------------------------- -!For reference -! REAL , PARAMETER :: karman = 0.4 -! REAL , PARAMETER :: g = 9.81 -! REAL , PARAMETER :: r_d = 287. -! REAL , PARAMETER :: cp = 7.*r_d/2. -! REAL , PARAMETER :: r_v = 461.6 -! REAL , PARAMETER :: cpv = 4.*r_v -! REAL , PARAMETER :: cliq = 4190. -! REAL , PARAMETER :: Cice = 2106. -! REAL , PARAMETER :: rcp = r_d/cp -! REAL , PARAMETER :: XLS = 2.85E6 -! REAL , PARAMETER :: XLV = 2.5E6 -! REAL , PARAMETER :: XLF = 3.50E5 -! REAL , PARAMETER :: p1000mb = 100000. -! REAL , PARAMETER :: rvovrd = r_v/r_d -! REAL , PARAMETER :: SVP1 = 0.6112 -! REAL , PARAMETER :: SVP2 = 17.67 -! REAL , PARAMETER :: SVP3 = 29.65 -! REAL , PARAMETER :: SVPT0 = 273.15 -! REAL , PARAMETER :: EP_1 = R_v/R_d-1. -! REAL , PARAMETER :: EP_2 = R_d/R_v -! - - real(kind=kind_phys), intent(in) :: cp, g, r_d, r_v, cpv, & - & cliq, Cice, rcp, XLV, XLF, EP_1, EP_2 - real(kind=kind_phys) :: xlvcp, xlscp, ev, rd, & - & rk, svp11, p608, ep_3,tv0, tv1, gtr,g_inv, huge + real(kind=kind_phys) :: huge + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg - REAL, PARAMETER :: tref=300.0 !< reference temperature (K) - REAL, PARAMETER :: TKmin=253.0 !< for total water conversion, Tripoli and Cotton (1981) + logical, intent(in) :: lssav, ldiag3d, lsidea, qdiag3d + logical, intent(in) :: cplflx - REAL, PARAMETER :: zero=0.0d0, one=1.0d0 -! REAL, PARAMETER :: huge=9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - LOGICAL, INTENT(IN) :: lssav, ldiag3d, lsidea, qdiag3d - LOGICAL, INTENT(IN) :: cplflx + !smoke/chem + !logical, intent(in) :: rrfs_smoke, rrfs_smoke, fire_turb + !integer, intent(in) :: nchem, ndvel, kdvel + !for testing only: + logical, parameter :: rrfs_smoke=.false., mix_chem=.false., fire_turb=.false. + integer, parameter :: nchem=2, ndvel=2, kdvel=1 ! NAMELIST OPTIONS (INPUT): - LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & - lprnt, do_mynnsfclay, & - flag_for_pbl_generic_tend - INTEGER, INTENT(IN) :: & + logical, intent(in) :: & + & bl_mynn_tkeadvect, & + & bl_mynn_tkebudget, & + & ltaerosol, & + & lprnt, & + & do_mynnsfclay, & + & flag_for_pbl_generic_tend + integer, intent(in) :: & & bl_mynn_cloudpdf, & & bl_mynn_mixlength, & & icloud_bl, & @@ -205,25 +202,24 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_edmf_tke, & & bl_mynn_cloudmix, & & bl_mynn_mixqt, & - & bl_mynn_tkebudget, & & bl_mynn_output, & - & grav_settling, & & imp_physics, imp_physics_wsm6, & & imp_physics_thompson, imp_physics_gfdl + real, intent(in) :: & + & bl_mynn_closure !TENDENCY DIAGNOSTICS real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) - integer, intent(in) :: index_of_temperature, index_of_x_wind, & - index_of_y_wind, index_of_process_pbl - integer, intent(in) :: ntoz, ntqv, ntcw, ntiw, ntlnc, ntinc, ntwa, ntia, ntke + integer, intent(in) :: index_of_temperature, index_of_x_wind + integer, intent(in) :: index_of_y_wind, index_of_process_pbl + integer, intent(in) :: ntoz, ntqv, ntcw, ntiw, ntlnc + integer, intent(in) :: ntinc, ntwa, ntia, ntke !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: & & spp_pbl=0, & & bl_mynn_mixscalars=1 - REAL, PARAMETER :: & - & closure=2.6 !2.5, 2.6 or 3.0 LOGICAL :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & & FLAG_QNWFA, FLAG_QNIFA @@ -238,15 +234,14 @@ SUBROUTINE mynnedmf_wrapper_run( & INTEGER, intent(in) :: im, levs LOGICAL, intent(in) :: flag_init, flag_restart INTEGER :: initflag, k, i - INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - INTEGER :: kdvel, num_vert_mix - INTEGER, PARAMETER :: nchem=1, ndvel=1 + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & + & ITS,ITE,JTS,JTE,KTS,KTE + REAL(kind=kind_phys) :: tem !MYNN-3D - real(kind=kind_phys), dimension(:,:), intent(in) :: phii + real(kind=kind_phys), dimension(:,:), intent(in) :: phii real(kind=kind_phys), dimension(:,:), intent(inout) :: & & dtdt, dudt, dvdt, & & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & @@ -255,43 +250,50 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), dimension(:,:), intent(inout) :: & & qke, qke_adv, EL_PBL, Sh3D, & & qc_bl, qi_bl, cldfra_bl -!These 10 arrays are only allocated when bl_mynn_output > 0 + !These 10 arrays are only allocated when bl_mynn_output > 0 real(kind=kind_phys), dimension(:,:), intent(inout) :: & & edmf_a,edmf_w,edmf_qt, & & edmf_thl,edmf_ent,edmf_qc, & & sub_thl,sub_sqv,det_thl,det_sqv - real(kind=kind_phys), dimension(:,:), intent(in) :: & - & u,v,omega,t3d, & - & exner,prsl, & - & qgrs_water_vapor, & - & qgrs_liquid_cloud, & - & qgrs_ice_cloud, & - & qgrs_cloud_droplet_num_conc, & - & qgrs_cloud_ice_num_conc, & - & qgrs_ozone, & - & qgrs_water_aer_num_conc, & - & qgrs_ice_aer_num_conc - real(kind=kind_phys), dimension(:,:), intent(out) :: & - & Tsq, Qsq, Cov, exch_h, exch_m - real(kind=kind_phys), dimension(:), intent(in) :: xmu - real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw + real(kind=kind_phys), dimension(:,:), intent(inout) :: & + & dqke,qWT,qSHEAR,qBUOY,qDISS + real(kind=kind_phys), dimension(:,:), intent(inout) :: & + & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud + + real(kind=kind_phys), dimension(:,:), intent(in) :: & + & u,v,omega, & + & exner,prsl, & + & qgrs_cloud_droplet_num_conc, & + & qgrs_cloud_ice_num_conc, & + & qgrs_ozone, & + & qgrs_water_aer_num_conc, & + & qgrs_ice_aer_num_conc + real(kind=kind_phys), dimension(:,:), intent(out) :: & + & Tsq, Qsq, Cov, exch_h, exch_m + real(kind=kind_phys), dimension(:), intent(in) :: xmu + real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw !LOCAL real(kind=kind_phys), dimension(im,levs) :: & & sqv,sqc,sqi,qnc,qni,ozone,qnwfa,qnifa, & - & dz, w, p, rho, th, qv, & + & dz, w, p, rho, th, qv, delp, & & RUBLTEN, RVBLTEN, RTHBLTEN, RQVBLTEN, & & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, & & RQNWFABLTEN, RQNIFABLTEN, & - & dqke,qWT,qSHEAR,qBUOY,qDISS, & & pattern_spp_pbl real(kind=kind_phys), allocatable :: old_ozone(:,:) -!MYNN-CHEM arrays - real(kind=kind_phys), dimension(im,nchem) :: chem3d - real(kind=kind_phys), dimension(im,ndvel) :: vd3d - REAL(kind=kind_phys), DIMENSION( levs, nchem ) :: chem1 - REAL(kind=kind_phys), DIMENSION( levs+1, nchem ) :: s_awchem1 - REAL(kind=kind_phys), DIMENSION( ndvel ) :: vd1 +!smoke/chem arrays + ! real(kind=kind_phys), dimension(:,:), intent(inout), optional :: & + ! & qgrs_smoke_conc, qgrs_dust_conc + ! real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d + ! real(kind=kind_phys), dimension(:,:), intent(in), optional :: vdep + ! real(kind=kind_phys), dimension(:), intent(in), optional :: frp, emis_ant_no +!for testing only + real(kind=kind_phys), dimension(im,levs) :: & + & qgrs_smoke_conc, qgrs_dust_conc + real(kind=kind_phys), allocatable, dimension(:,:,:) :: chem3d + real(kind=kind_phys), dimension(im,ndvel) :: vdep !not passed in yet??? + real(kind=kind_phys), dimension(im) :: frp, emis_ant_no !MYNN-2D real(kind=kind_phys), dimension(:), intent(in) :: & @@ -322,8 +324,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !LOCAL real, dimension(im) :: & - & WSTAR,DELTA,qcg,hfx,qfx,rmol,xland, & - & uoce,voce,vdfg,znt,ts + & hfx,qfx,rmol,xland,uoce,voce,vdfg,znt,ts integer :: idtend real, dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 real(kind=kind_phys), allocatable :: save_qke_adv(:,:) @@ -339,12 +340,12 @@ SUBROUTINE mynnedmf_wrapper_run( & write(0,*)"flag_restart=",flag_restart endif - if(.not. flag_for_pbl_generic_tend .and. ldiag3d) then - idtend = dtidx(ntke+100,index_of_process_pbl) - if(idtend>=1) then - allocate(save_qke_adv(im,levs)) - save_qke_adv=qke_adv - endif + if (.not. flag_for_pbl_generic_tend .and. ldiag3d) then + idtend = dtidx(ntke+100,index_of_process_pbl) + if (idtend>=1) then + allocate(save_qke_adv(im,levs)) + save_qke_adv=qke_adv + endif endif ! DH* TODO: Use flag_restart to distinguish which fields need @@ -356,19 +357,49 @@ SUBROUTINE mynnedmf_wrapper_run( & initflag=0 !print*,"in MYNN, initflag=",initflag endif - - xlvcp=xlv/cp - xlscp=(xlv+xlf)/cp - ev=xlv - rd=r_d - rk=cp/rd - svp11=svp1*1.e3 - p608=ep_1 - ep_3=1.-ep_2 - tv0=p608*tref - tv1=(1.+p608)*tref - gtr=g/tref - g_inv=1./g + + !initialize arrays for test + qgrs_smoke_conc = 1.0 + qgrs_dust_conc = 1.0 + FRP = 0. + EMIS_ANT_NO = 0. + vdep = 0. ! hli for chem dry deposition, 0 temporarily + if (rrfs_smoke) then + allocate ( chem3d(im,levs,nchem) ) + do k=1,levs + do i=1,im + chem3d(i,k,1)=qgrs_smoke_conc(i,k) + chem3d(i,k,2)=qgrs_dust_conc (i,k) + enddo + enddo + endif + + ! Check incoming moist species to ensure non-negative values + ! First, create height (dz) and pressure differences (delp) + ! across model layers + do k=1,levs + do i=1,im + dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv + enddo + enddo + + do i=1,im + delp(i,1) = ps(i) - (prsl(i,2)*dz(i,1) + prsl(i,1)*dz(i,2))/(dz(i,1)+dz(i,2)) + do k=2,levs-1 + delp(i,k) = (prsl(i,k)*dz(i,k-1) + prsl(i,k-1)*dz(i,k))/(dz(i,k)+dz(i,k-1)) - & + (prsl(i,k+1)*dz(i,k) + prsl(i,k)*dz(i,k+1))/(dz(i,k)+dz(i,k+1)) + enddo + delp(i,levs) = delp(i,levs-1) + enddo + + do i=1,im + call moisture_check2(levs, delt, & + delp(i,:), exner(i,:), & + qgrs_water_vapor(i,:), & + qgrs_liquid_cloud(i,:),& + qgrs_ice_cloud(i,:), & + t3d(i,:) ) + enddo ! Assign variables for each microphysics scheme if (imp_physics == imp_physics_wsm6) then @@ -517,14 +548,14 @@ SUBROUTINE mynnedmf_wrapper_run( & do k=1,levs do i=1,im - dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv + ! dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv th(i,k)=t3d(i,k)/exner(i,k) ! keep as specific humidity ! qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) ! qc(i,k)=qc(i,k)/(1.0 - qvsh(i,k)) ! qi(i,k)=qi(i,k)/(1.0 - qvsh(i,k)) rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) - w(i,k) = -omega(i,k)/(rho(i,k)*g) + w(i,k) = -omega(i,k)/(rho(i,k)*grav) pattern_spp_pbl(i,k)=0.0 enddo enddo @@ -541,9 +572,6 @@ SUBROUTINE mynnedmf_wrapper_run( & ch(i)=0.0 hfx(i)=hflx(i)*rho(i,1)*cp qfx(i)=qflx(i)*rho(i,1) - wstar(i)=0.0 - delta(i)=0.0 - qcg(i)=0.0 dtsfc1(i) = hfx(i) dqsfc1(i) = qfx(i)*XLV @@ -658,21 +686,23 @@ SUBROUTINE mynnedmf_wrapper_run( & CALL mynn_bl_driver( & & initflag=initflag,restart=flag_restart, & & cycling=cycling, & - & grav_settling=grav_settling, & & delt=delt,dz=dz,dx=dx,znt=znt, & & u=u,v=v,w=w,th=th,sqv3D=sqv,sqc3D=sqc, & - & sqi3D=sqi,qni=qni,qnc=qnc, & + & sqi3D=sqi,qnc=qnc,qni=qni, & & qnwfa=qnwfa,qnifa=qnifa,ozone=ozone, & & p=prsl,exner=exner,rho=rho,T3D=t3d, & - & xland=xland,ts=ts,qsfc=qsfc,qcg=qcg,ps=ps, & + & xland=xland,ts=ts,qsfc=qsfc,ps=ps, & & ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol, & & wspd=wspd,uoce=uoce,voce=voce,vdfg=vdfg, & !input - & qke=QKE,sh3d=Sh3d, & !output - & qke_adv=qke_adv,bl_mynn_tkeadvect=bl_mynn_tkeadvect,& -#if (WRF_CHEM == 1) - & chem3d=chem,vd3d=vd,nchem=nchem,kdvel=kdvel, & - & ndvel=ndvel,num_vert_mix=num_vert_mix, & -#endif + & qke=QKE,qke_adv=qke_adv, & !output + & bl_mynn_tkeadvect=bl_mynn_tkeadvect,sh3d=Sh3d, & +!chem/smoke + & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & + & Chem3d=chem3d,Vdep=vdep, & + & rrfs_smoke=rrfs_smoke, & + & FRP=frp,EMIS_ANT_NO=emis_ant_no, & + & mix_chem=mix_chem,fire_turb=fire_turb, & +!----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output & RQVBLTEN=RQVBLTEN,RQCBLTEN=rqcblten, & @@ -684,13 +714,12 @@ SUBROUTINE mynnedmf_wrapper_run( & & ,el_pbl=el_pbl & !output & ,dqke=dqke & !output & ,qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS & !output - & ,WSTAR=wstar,DELTA=delta & !unused input & ,bl_mynn_tkebudget=bl_mynn_tkebudget & !input parameter & ,bl_mynn_cloudpdf=bl_mynn_cloudpdf & !input parameter & ,bl_mynn_mixlength=bl_mynn_mixlength & !input parameter & ,icloud_bl=icloud_bl & !input parameter & ,qc_bl=qc_bl,qi_bl=qi_bl,cldfra_bl=cldfra_bl & !output - & ,closure=closure,bl_mynn_edmf=bl_mynn_edmf & !input parameter + & ,closure=bl_mynn_closure,bl_mynn_edmf=bl_mynn_edmf & !input parameter & ,bl_mynn_edmf_mom=bl_mynn_edmf_mom & !input parameter & ,bl_mynn_edmf_tke=bl_mynn_edmf_tke & !input parameter & ,bl_mynn_mixscalars=bl_mynn_mixscalars & !input parameter @@ -935,6 +964,10 @@ SUBROUTINE mynnedmf_wrapper_run( & deallocate(save_qke_adv) endif + if(allocated(chem3d))then + deallocate(chem3d) + endif + CONTAINS SUBROUTINE dtend_helper(itracer,field,mult) @@ -953,6 +986,89 @@ SUBROUTINE dtend_helper(itracer,field,mult) endif END SUBROUTINE dtend_helper +! ================================================================== + SUBROUTINE moisture_check2(kte, delt, dp, exner, & + qv, qc, qi, th ) + ! + ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, + ! force them to be larger than minimum value by (1) condensating + ! water vapor into liquid or ice, and (2) by transporting water vapor + ! from the very lower layer. + ! + ! We then update the final state variables and tendencies associated + ! with this correction. If any condensation happens, update theta/temperature too. + ! Note that (qv,qc,qi,th) are the final state variables after + ! applying corresponding input tendencies and corrective tendencies. + + implicit none + integer, intent(in) :: kte + real, intent(in) :: delt + real, dimension(kte), intent(in) :: dp, exner + real, dimension(kte), intent(inout) :: qv, qc, qi, th + integer k + real :: dqc2, dqi2, dqv2, sum, aa, dum + real, parameter :: qvmin1= 1e-8, & !min at k=1 + qvmin = 1e-20, & !min above k=1 + qcmin = 0.0, & + qimin = 0.0 + + do k = kte, 1, -1 ! From the top to the surface + dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) + dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + + !update species + qc(k) = qc(k) + dqc2 + qi(k) = qi(k) + dqi2 + qv(k) = qv(k) - dqc2 - dqi2 + !for theta + !th(k) = th(k) + xlvcp/exner(k)*dqc2 + & + ! xlscp/exner(k)*dqi2 + !for temperature + th(k) = th(k) + xlvcp*dqc2 + & + xlscp*dqi2 + + !then fix qv if lending qv made it negative + if (k .eq. 1) then + dqv2 = max(0.0, qvmin1-qv(k)) !qv deficit (>=0) + qv(k) = qv(k) + dqv2 + qv(k) = max(qv(k),qvmin1) + dqv2 = 0.0 + else + dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) + qv(k) = qv(k) + dqv2 + qv(k-1)= qv(k-1) - dqv2*dp(k)/dp(k-1) + qv(k) = max(qv(k),qvmin) + endif + qc(k) = max(qc(k),qcmin) + qi(k) = max(qi(k),qimin) + end do + + ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv2 .gt. 1.e-20 ) then + sum = 0.0 + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) + enddo + aa = dqv2*dp(1)/max(1.e-20,sum) + if( aa .lt. 0.5 ) then + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) then + dum = aa*qv(k) + qv(k) = qv(k) - dum + endif + enddo + else + ! For testing purposes only (not yet found in any output): + ! write(*,*) 'Full moisture conservation is impossible' + endif + endif + + return + + END SUBROUTINE moisture_check2 + END SUBROUTINE mynnedmf_wrapper_run !###================================================================= diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 25dc89efe..b413e81de 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -7,69 +7,7 @@ [ccpp-arg-table] name = mynnedmf_wrapper_init type = scheme -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[lheatstrg] - standard_name = flag_for_canopy_heat_storage_in_land_surface_scheme - long_name = flag for canopy heat storage parameterization - 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_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - -##################################################################### -[ccpp-arg-table] - name = mynnedmf_wrapper_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[flag_init] - standard_name = flag_for_first_timestep - long_name = flag signaling first time step for time integration loop - units = flag - dimensions = () - type = logical - intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in -[cp] +[con_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 @@ -77,7 +15,7 @@ type = real kind = kind_phys intent = in -[g] +[con_grav] standard_name = gravitational_acceleration long_name = gravitational acceleration units = m s-2 @@ -85,7 +23,7 @@ type = real kind = kind_phys intent = in -[r_d] +[con_rd] standard_name = gas_constant_of_dry_air long_name = ideal gas constant for dry air units = J kg-1 K-1 @@ -93,7 +31,7 @@ type = real kind = kind_phys intent = in -[r_v] +[con_rv] standard_name = gas_constant_water_vapor long_name = ideal gas constant for water vapor units = J kg-1 K-1 @@ -101,7 +39,7 @@ type = real kind = kind_phys intent = in -[cpv] +[con_cpv] standard_name = specific_heat_of_water_vapor_at_constant_pressure long_name = specific heat of water vapor at constant pressure units = J kg-1 K-1 @@ -109,7 +47,7 @@ type = real kind = kind_phys intent = in -[cliq] +[con_cliq] standard_name = specific_heat_of_liquid_water_at_constant_pressure long_name = specific heat of liquid water at constant pressure units = J kg-1 K-1 @@ -117,7 +55,7 @@ type = real kind = kind_phys intent = in -[Cice] +[con_cice] standard_name = specific_heat_of_ice_at_constant_pressure long_name = specific heat of ice at constant pressure units = J kg-1 K-1 @@ -125,7 +63,7 @@ type = real kind = kind_phys intent = in -[rcp] +[con_rcp] standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure long_name = (rd/cp) units = none @@ -133,7 +71,7 @@ type = real kind = kind_phys intent = in -[XLV] +[con_xlv] standard_name = latent_heat_of_vaporization_of_water_at_0C long_name = latent heat of evaporation/sublimation units = J kg-1 @@ -141,7 +79,7 @@ type = real kind = kind_phys intent = in -[XLF] +[con_xlf] standard_name = latent_heat_of_fusion_of_water_at_0C long_name = latent heat of fusion units = J kg-1 @@ -149,7 +87,7 @@ type = real kind = kind_phys intent = in -[EP_1] +[con_p608] 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 @@ -157,7 +95,7 @@ type = real kind = kind_phys intent = in -[EP_2] +[con_ep2] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants long_name = rd/rv units = none @@ -165,6 +103,83 @@ type = real kind = kind_phys intent = in +[con_karman] + standard_name = von_karman_constant + long_name = von karman constant + units = none + dimensions = () + type = real + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in +[lheatstrg] + standard_name = flag_for_canopy_heat_storage_in_land_surface_scheme + long_name = flag for canopy heat storage parameterization + 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_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + +##################################################################### +[ccpp-arg-table] + name = mynnedmf_wrapper_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[flag_init] + standard_name = flag_for_first_timestep + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in [lssav] standard_name = flag_for_diagnostics long_name = logical flag for storing diagnostics @@ -271,7 +286,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = in + intent = inout [qgrs_water_vapor] standard_name = specific_humidity long_name = water vapor specific humidity @@ -279,7 +294,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = in + intent = inout [qgrs_liquid_cloud] standard_name = cloud_liquid_water_mixing_ratio long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) @@ -287,7 +302,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = in + intent = inout [qgrs_ice_cloud] standard_name = cloud_ice_mixing_ratio long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) @@ -295,7 +310,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = in + intent = inout [qgrs_cloud_droplet_num_conc] standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air long_name = number concentration of cloud droplets (liquid) @@ -765,6 +780,46 @@ type = real kind = kind_phys intent = out +[dqke] + standard_name = total_time_rate_of_change_of_tke + long_name = total tke tendency + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[qwt] + standard_name = tke_tendency_due_to_vertical_transport + long_name = tke tendency due to vertical transport and diffusion + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[qshear] + standard_name = tke_tendency_due_to_shear + long_name = tke tendency due to shear + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[qbuoy] + standard_name = tke_tendency_due_to_buoyancy + long_name = tke tendency due to buoyancy production or consumption + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[qdiss] + standard_name = tke_tendency_due_to_dissipation + long_name = tke tendency due to the dissipation of tke + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [PBLH] standard_name = atmosphere_boundary_layer_thickness long_name = PBL thickness @@ -1131,19 +1186,12 @@ type = real kind = kind_phys intent = in -[grav_settling] - standard_name = control_for_gravitational_settling_of_cloud_droplets - long_name = flag to activate gravitational setting of fog - units = flag - dimensions = () - type = integer - intent = in [bl_mynn_tkebudget] standard_name = control_for_tke_budget_output long_name = flag for activating TKE budget units = flag dimensions = () - type = integer + type = logical intent = in [bl_mynn_tkeadvect] standard_name = flag_for_tke_advection @@ -1208,6 +1256,13 @@ dimensions = () type = integer intent = in +[bl_mynn_closure] + standard_name = control_for_closure_level_in_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to determine the closure level for the mynn + units = flag + dimensions = () + type = real + intent = in [icloud_bl] standard_name = control_for_sgs_cloud_radiation_coupling_in_mellor_yamamda_nakanishi_niino_pbl_scheme long_name = flag for coupling sgs clouds to radiation diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index a492e50e0..3ab549e98 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1,9 +1,107 @@ !>\file module_bl_mynn.F90 !! This file contains the entity of MYNN-EDMF PBL scheme. -!WRF:MODEL_LAYER:PHYSICS -! -! Translated from NN f77 to F90 and put into WRF by Mariusz Pagowski -! NOAA/GSD & CIRA/CSU, Feb 2008 +! ********************************************************************** +! * An improved Mellor-Yamada turbulence closure model * +! * * +! * Original author: M. Nakanishi (N.D.A), naka@nda.ac.jp * +! * Translated into F90 and implemented in WRF-ARW by: * +! * Mariusz Pagowski (NOAA-GSL) * +! * Subsequently developed by: * +! * Joseph Olson, Jaymes Kenyon (NOAA/GSL), * +! * Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), * +! * Franciano Puhales (UFSM), Laura Fowler (NCAR), * +! * Elynn Wu (UCSD), and Jordan Schnell (NOAA/GSL) * +! * * +! * Contents: * +! * * +! * mynn_bl_driver - main subroutine which calls all other routines * +! * -------------- * +! * 1. mym_initialize (to be called once initially) * +! * gives the closure constants and initializes the turbulent * +! * quantities. * +! * 2. get_pblh * +! * Calculates the boundary layer height * +! * 3. scale_aware * +! * Calculates scale-adaptive tapering functions * +! * 4. mym_condensation * +! * determines the liquid water content and the cloud fraction * +! * diagnostically. * +! * 5. dmp_mf * +! * Calls the (nonlocal) mass-flux component * +! * 6. ddmf_jpl * +! * Calls the downdraft mass-flux component * +! * (-) mym_level2 (called in the other subroutines) * +! * calculates the stability functions at Level 2. * +! * (-) mym_length (called in the other subroutines) * +! * calculates the master length scale. * +! * 7. mym_turbulence * +! * calculates the vertical diffusivity coefficients and the * +! * production terms for the turbulent quantities. * +! * 8. mym_predict * +! * predicts the turbulent quantities at the next step. * +! * * +! * call mym_initialize * +! * | * +! * |<----------------+ * +! * | | * +! * call get_pblh | * +! * call scale_aware | * +! * call mym_condensation | * +! * call dmp_mf | * +! * call ddmf_jpl | * +! * call mym_turbulence | * +! * call mym_predict | * +! * | | * +! * |-----------------+ * +! * | * +! * end * +! * * +! * Variables worthy of special mention: * +! * tref : Reference temperature * +! * thl : Liquid water potential temperature * +! * qw : Total water (water vapor+liquid water) content * +! * ql : Liquid water content * +! * vt, vq : Functions for computing the buoyancy flux * +! * qke : 2 * TKE * +! * el : mixing length * +! * * +! * If the water contents are unnecessary, e.g., in the case of * +! * ocean models, thl is the potential temperature and qw, ql, vt * +! * and vq are all zero. * +! * * +! * Grid arrangement: * +! * k+1 +---------+ * +! * | | i = 1 - nx * +! * (k) | * | k = 1 - nz * +! * | | * +! * k +---------+ * +! * i (i) i+1 * +! * * +! * All the predicted variables are defined at the center (*) of * +! * the grid boxes. The diffusivity coefficients and two of their * +! * components (el and stability functions sh & sm) are, however, * +! * defined on the walls of the grid boxes. * +! * # Upper boundary values are given at k=nz. * +! * * +! * References: * +! * 1. Nakanishi, M., 2001: * +! * Boundary-Layer Meteor., 99, 349-378. * +! * 2. Nakanishi, M. and H. Niino, 2004: * +! * Boundary-Layer Meteor., 112, 1-31. * +! * 3. Nakanishi, M. and H. Niino, 2006: * +! * Boundary-Layer Meteor., 119, 397-407. * +! * 4. Nakanishi, M. and H. Niino, 2009: * +! * Jour. Meteor. Soc. Japan, 87, 895-912. * +! * 5. Olson J. and coauthors, 2019: A description of the * +! * MYNN-EDMF scheme and coupling to other components in * +! * WRF-ARW. NOAA Tech. Memo. OAR GSD, 61, 37 pp., * +! * https://doi.org/10.25923/n9wm-be49. * +! * 6. Puhales, Franciano S. and coauthors, 2020: Turbulent * +! * Kinetic Energy Budget for MYNN-EDMF PBL Scheme in WRF model.* +! * Universidade Federal de Santa Maria Technical Note. 9 pp. * +! ********************************************************************** +! ================================================================== +! Notes on original implementation into WRF-ARW ! changes to original code: ! 1. code is 1D (in z) ! 2. option to advect TKE, but not the covariances and variances @@ -13,11 +111,8 @@ ! 5. cosmetic changes to adhere to WRF standard (remove common blocks, ! intent etc) !------------------------------------------------------------------- -!Modifications implemented by Joseph Olson and Jaymes Kenyon (NOAA/GSL), -!Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), Franciano Puhales (UFSM), -!Laura Fowler (NCAR), and Elynn Wu (UCSD) +! Further modifications post-implementation ! -! Departures from original MYNN (Nakanish & Niino 2009) ! 1. Addition of BouLac mixing length in the free atmosphere. ! 2. Changed the turbulent mixing length to be integrated from the ! surface to the top of the BL + a transition layer depth. @@ -121,14 +216,14 @@ ! Misc small-impact bugfixes: ! 1) dz was incorrectly indexed in mym_condensation ! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.3 / CCPP +! v4.3.2 / CCPP ! This version includes many modifications that proved valuable in the global ! framework and removes some key lingering bugs in the mixing of chemical species. ! TKE Budget output fixed (Puhales, 2020-12) ! New option for stability function: (Puhales, 2020-12) ! bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 ) -! bl_mynn_stfunc = 1 (new (for test), same used for Jimenez et al (MWR) -! see the Technical Note for this implementation). +! bl_mynn_stfunc = 1 (expanded range, same as used for Jimenez et al (MWR) +! see the Technical Note for this implementation. ! Improved conservation of momentum and higher-order moments. ! Important bug fixes for mixing of chemical species. ! Addition of pressure-gradient effects on updraft momentum transport. @@ -136,44 +231,97 @@ ! Addition of sig_order to regulate the use of higher-order moments ! for sigma when using bl_mynn_cloudpdf = 2 (Chab-Becht). This ! new option is set in the subroutine mym_condensation. +! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. ! -! Many of these changes are now documented in: -! Olson, J. B., J. S. Kenyon, W. M. Angevine, J. M. Brown, M. Pagowski, and K. Suselj, 2019: -! A description of the MYNN-EDMF scheme and coupling to other components in WRF-ARW. -! NOAA Tech. Memo. OAR GSD, 61, 37 pp., https://doi.org/10.25923/n9wm-be49. -! Puhales, Franciano S., Joseph B. Olson, Jimy Dudhia, Douglas Lima de Bem, Rafael Maroneze, -! Otavio C. Acevedo, Felipe D. Costa, and Vagner Anabor, 2020: Turbulent Kinetic Energy -! Budget for MYNN-EDMF PBL Scheme in WRF model. Universidade Federal de Santa Maria Technical Note. 9 pp. -!------------------------------------------------------------------- +! Many of these changes are now documented in references listed above. +!==================================================================== -MODULE module_bl_mynn + module bl_mynn_common + +!------------------------------------------ +!Define Model-specific constants/parameters. +!This module will be used at the initialization stage +!where all model-specific constants are read and saved into +!memory. This module is then used again in the MYNN-EDMF. All +!MYNN-specific constants are declared globally in the main +!module (module_bl_mynn) further below: +!------------------------------------------ + +! The following 5-6 lines are the only lines in this file that are not +! universal for all dycores... Any ideas how to universalize it? +! For MPAS: +! use mpas_kind_types,only: kind_phys => RKIND +! For CCPP: + use machine, only : kind_phys + + implicit none + save + +! To be specified from dycore + real(kind=kind_phys):: cp != 7.*r_d/2. (J/kg/K) + real(kind=kind_phys):: cpv != 4.*r_v (J/kg/K) Spec heat H2O gas + real(kind=kind_phys):: cice != 2106. (J/kg/K) Spec heat H2O ice + real(kind=kind_phys):: cliq != 4190. (J/kg/K) Spec heat H2O liq + real(kind=kind_phys):: p608 != R_v/R_d-1. + real(kind=kind_phys):: ep_2 != R_d/R_v + real(kind=kind_phys):: grav != accel due to gravity + real(kind=kind_phys):: karman != von Karman constant + real(kind=kind_phys):: t0c != temperature of water at freezing, 273.15 K + real(kind=kind_phys):: rcp != r_d/cp + real(kind=kind_phys):: r_d != 287. (J/kg/K) gas const dry air + real(kind=kind_phys):: r_v != 461.6 (J/kg/K) gas const water + real(kind=kind_phys):: xlf != 0.35E6 (J/kg) fusion at 0 C + real(kind=kind_phys):: xlv != 2.50E6 (J/kg) vaporization at 0 C + real(kind=kind_phys):: xls != 2.85E6 (J/kg) sublimation + real(kind=kind_phys):: rvovrd != r_v/r_d != 1.608 + +! Specified locally + real(kind=kind_phys),parameter:: zero = 0.0 + real(kind=kind_phys),parameter:: half = 0.5 + real(kind=kind_phys),parameter:: one = 1.0 + real(kind=kind_phys),parameter:: two = 2.0 + real(kind=kind_phys),parameter:: onethird = 1./3. + real(kind=kind_phys),parameter:: twothirds = 2./3. + real(kind=kind_phys),parameter:: tref = 300.0 ! reference temperature (K) + real(kind=kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) + real(kind=kind_phys),parameter:: p1000mb=100000.0 + real(kind=kind_phys),parameter:: svp1 = 0.6112 !(kPa) + real(kind=kind_phys),parameter:: svp2 = 17.67 !(dimensionless) + real(kind=kind_phys),parameter:: svp3 = 29.65 !(K) + real(kind=kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice + +! To be derived in the init routine + real(kind=kind_phys):: ep_3 != 1.-ep_2 != 0.378 + real(kind=kind_phys):: gtr != grav/tref + real(kind=kind_phys):: rk != cp/r_d + real(kind=kind_phys):: tv0 != p608*tref + real(kind=kind_phys):: tv1 != (1.+p608)*tref + real(kind=kind_phys):: xlscp != (xlv+xlf)/cp + real(kind=kind_phys):: xlvcp != xlv/cp + real(kind=kind_phys):: g_inv != 1./grav + + end module bl_mynn_common !================================================================== -!FV3 CONSTANTS - use physcons, only : cp => con_cp, & - & g => con_g, & - & r_d => con_rd, & - & r_v => con_rv, & - & cpv => con_cvap, & - & cliq => con_cliq, & - & Cice => con_csol, & - & rcp => con_rocp, & - & XLV => con_hvap, & - & XLF => con_hfus, & - & EP_1 => con_fvirt, & - & EP_2 => con_eps + +MODULE module_bl_mynn + + use bl_mynn_common,only: & + cp , cpv , cliq , cice , & + p608 , ep_2 , ep_3 , gtr , & + grav , g_inv , karman , p1000mb , & + rcp , r_d , r_v , rk , & + rvovrd , svp1 , svp2 , svp3 , & + xlf , xlv , xls , xlscp , & + xlvcp , tv0 , tv1 , tref , & + zero , half , one , two , & + onethird , twothirds , tkmin , t0c , & + tice + IMPLICIT NONE - REAL , PARAMETER :: karman = 0.4 - REAL , PARAMETER :: XLS = 2.85E6 - REAL , PARAMETER :: p1000mb = 100000. - REAL , PARAMETER :: rvovrd = r_v/r_d - REAL , PARAMETER :: SVP1 = 0.6112 - REAL , PARAMETER :: SVP2 = 17.67 - REAL , PARAMETER :: SVP3 = 29.65 - REAL , PARAMETER :: SVPT0 = 273.15 INTEGER , PARAMETER :: param_first_scalar = 1, & & p_qc = 2, & @@ -188,9 +336,9 @@ MODULE module_bl_mynn !==================================================================== !WRF CONSTANTS ! USE module_model_constants, only: & -! &karman, g, p1000mb, & +! &karman, grav, p1000mb, & ! &cp, r_d, r_v, rcp, xlv, xlf, xls, & -! &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & +! &svp1, svp2, svp3, p608, ep_2, rvovrd, & ! &cpv, cliq, cice ! ! USE module_state_description, only: param_first_scalar, & @@ -205,24 +353,16 @@ MODULE module_bl_mynn REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & cphh_st=5.0, cphh_unst=16.0 - REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & - &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2 - - REAL, PARAMETER :: tref=300.0 !< reference temperature (K) - REAL, PARAMETER :: TKmin=253.0 !< for total water conversion, Tripoli and Cotton (1981) - REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref - ! Closure constants - REAL, PARAMETER :: & - &vk = karman, & + REAL, PARAMETER :: & &pr = 0.74, & &g1 = 0.235, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 + &b1 = 24.0, & + &b2 = 15.0, & ! CKmod NN2009 &c2 = 0.729, & ! 0.729, & !0.75, & &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & + &c4 = 0.0, & + &c5 = 0.2, & &a1 = b1*( 1.0-3.0*g1 )/6.0, & ! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & @@ -244,18 +384,11 @@ MODULE module_bl_mynn ! Note that the following mixing-length constants are now specified in mym_length ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 -! Constants for gravitational settling -! REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8 - REAL, PARAMETER :: gno=1.0 !< original value seems too agressive: 4.64158883361278196 REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 -! 'parameters' for Poisson distribution (EDMF scheme) - REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, & - onethird = 1./3., twothirds = 2./3. - !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the !!Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). @@ -271,10 +404,6 @@ MODULE module_bl_mynn !!for TKE in the upper PBL/cloud layer. REAL, PARAMETER :: scaleaware=1. - !>Temporary switch to deactivate the mixing of chemical species (if WRF_CHEM = 1) - LOGICAL, PARAMETER :: mynn_chem_vertmx = .false. - LOGICAL, PARAMETER :: enh_vermix = .false. - !>Of the following the options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling INTEGER, PARAMETER :: bl_mynn_topdown = 0 @@ -282,16 +411,18 @@ MODULE module_bl_mynn INTEGER, PARAMETER :: bl_mynn_edmf_dd = 0 !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0) - REAL, PARAMETER :: dheat_opt = 1. + INTEGER, PARAMETER :: dheat_opt = 1 !Option to activate environmental subsidence in mass-flux scheme - LOGICAL, PARAMETER :: env_subs = .true. + LOGICAL, PARAMETER :: env_subs = .false. !Option to switch flux-profile relationship for surface (from Puhales et al. 2020) + !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE INTEGER, PARAMETER :: bl_mynn_stfunc = 1 !option to print out more stuff for debugging purposes LOGICAL, PARAMETER :: debug_code = .false. + INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out ! JAYMES- !> Constants used for empirical calculations of saturation @@ -319,1316 +450,1601 @@ MODULE module_bl_mynn REAL, PARAMETER:: K8= .161444444E-12 ! end- -!JOE & JAYMES'S mods -! -! Mixing Length Options -!\authors Joe and Jaymes -! specifed through namelist: bl_mynn_mixlength -! added: 16 Apr 2015 -! -! 0: Uses original MYNN mixing length formulation (except elt is calculated from -! a 10-km vertical integration). No scale-awareness is applied to the master -! mixing length (el), regardless of "scaleaware" setting. -! -! 1 (*DEFAULT*): Instead of (0), uses BouLac mixing length in free atmosphere. -! This helps remove excessively large mixing in unstable layers aloft. Scale- -! awareness in dx is available via the "scaleaware" setting. As of Apr 2015, -! this mixing length formulation option is used in the ESRL RAP/HRRR configuration. -! -! 2: As in (1), but elb is lengthened using separate cloud mixing length functions -! for statically stable and unstable regimes. This elb adjustment is only -! possible for nonzero cloud fractions, such that cloud-free cells are treated -! as in (1), but BouLac calculation is used more sparingly - when elb > 500 m. -! This is to reduce the computational expense that comes with the BouLac calculation. -! Also, This option is scale-aware in dx if "scaleaware" = 1. (Following Ito et al. 2015). -! -!JOE & JAYMES- end - - - + ! Used in WRF-ARW module_physics_init.F INTEGER :: mynn_level - CHARACTER*128 :: mynn_message - - INTEGER, PARAMETER :: kdebug=27 CONTAINS -! ********************************************************************** -! * An improved Mellor-Yamada turbulence closure model * -! * * -! * Aug/2005 M. Nakanishi (N.D.A) * -! * Modified: Dec/2005 M. Nakanishi (N.D.A) * -! * naka@nda.ac.jp * -! * * -! * Contents: * -! * 1. mym_initialize (to be called once initially) * -! * gives the closure constants and initializes the turbulent * -! * quantities. * -! * (2) mym_level2 (called in the other subroutines) * -! * calculates the stability functions at Level 2. * -! * (3) mym_length (called in the other subroutines) * -! * calculates the master length scale. * -! * 4. mym_turbulence * -! * calculates the vertical diffusivity coefficients and the * -! * production terms for the turbulent quantities. * -! * 5. mym_predict * -! * predicts the turbulent quantities at the next step. * -! * 6. mym_condensation * -! * determines the liquid water content and the cloud fraction * -! * diagnostically. * -! * * -! * call mym_initialize * -! * | * -! * |<----------------+ * -! * | | * -! * call mym_condensation | * -! * call mym_turbulence | * -! * call mym_predict | * -! * | | * -! * |-----------------+ * -! * | * -! * end * -! * * -! * Variables worthy of special mention: * -! * tref : Reference temperature * -! * thl : Liquid water potential temperature * -! * qw : Total water (water vapor+liquid water) content * -! * ql : Liquid water content * -! * vt, vq : Functions for computing the buoyancy flux * -! * * -! * If the water contents are unnecessary, e.g., in the case of * -! * ocean models, thl is the potential temperature and qw, ql, vt * -! * and vq are all zero. * -! * * -! * Grid arrangement: * -! * k+1 +---------+ * -! * | | i = 1 - nx * -! * (k) | * | j = 1 - ny * -! * | | k = 1 - nz * -! * k +---------+ * -! * i (i) i+1 * -! * * -! * All the predicted variables are defined at the center (*) of * -! * the grid boxes. The diffusivity coefficients are, however, * -! * defined on the walls of the grid boxes. * -! * # Upper boundary values are given at k=nz. * -! * * -! * References: * -! * 1. Nakanishi, M., 2001: * -! * Boundary-Layer Meteor., 99, 349-378. * -! * 2. Nakanishi, M. and H. Niino, 2004: * -! * Boundary-Layer Meteor., 112, 1-31. * -! * 3. Nakanishi, M. and H. Niino, 2006: * -! * Boundary-Layer Meteor., (in press). * -! * 4. Nakanishi, M. and H. Niino, 2009: * -! * Jour. Meteor. Soc. Japan, 87, 895-912. * -! ********************************************************************** -! -! SUBROUTINE mym_initialize: -! -! Input variables: -! iniflag : <>0; turbulent quantities will be initialized -! = 0; turbulent quantities have been already -! given, i.e., they will not be initialized -! nx, ny, nz : Dimension sizes of the -! x, y and z directions, respectively -! tref : Reference temperature (K) -! dz(nz) : Vertical grid spacings (m) -! # dz(nz)=dz(nz-1) -! zw(nz+1) : Heights of the walls of the grid boxes (m) -! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) -! h(nx,ny) : G^(1/2) in the terrain-following coordinate -! # h=1-zg/zt, where zg is the height of the -! terrain and zt the top of the model domain -! pi0(nx,my,nz) : Exner function at zw*h+zg (J/kg K) -! defined by c_p*( p_basic/1000hPa )^kappa -! This is usually computed by integrating -! d(pi0)/dz = -h*g/tref. -! rmo(nx,ny) : Inverse of the Obukhov length (m^(-1)) -! flt, flq(nx,ny) : Turbulent fluxes of sensible and latent heat, -! respectively, e.g., flt=-u_*Theta_* (K m/s) -!! flt - liquid water potential temperature surface flux -!! flq - total water flux surface flux -! ust(nx,ny) : Friction velocity (m/s) -! pmz(nx,ny) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) -! is the first grid point above the surafce, z0 -! the roughness length and zeta=(z1*h+z0)*rmo -! phh(nx,ny) : phi_h at z1*h+z0 -! u, v(nx,nz,ny): Components of the horizontal wind (m/s) -! thl(nx,nz,ny) : Liquid water potential temperature -! (K) -! qw(nx,nz,ny) : Total water content Q_w (kg/kg) -! -! Output variables: -! ql(nx,nz,ny) : Liquid water content (kg/kg) -! v?(nx,nz,ny) : Functions for computing the buoyancy flux -! qke(nx,nz,ny) : Twice the turbulent kinetic energy q^2 -! (m^2/s^2) -! tsq(nx,nz,ny) : Variance of Theta_l (K^2) -! qsq(nx,nz,ny) : Variance of Q_w -! cov(nx,nz,ny) : Covariance of Theta_l and Q_w (K) -! el(nx,nz,ny) : Master length scale L (m) -! defined on the walls of the grid boxes -! -! Work arrays: see subroutine mym_level2 -! pd?(nx,nz,ny) : Half of the production terms at Level 2 -! defined on the walls of the grid boxes -! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) -! -! # As to dtl, ...gh, see subroutine mym_turbulence. -! -!------------------------------------------------------------------- - +! ================================================================== !>\ingroup gsd_mynn_edmf -!! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$, -!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. -!!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm +!! This subroutine is the GSD MYNN-EDNF PBL driver routine,which +!! encompassed the majority of the subroutines that comprise the +!! procedures that ultimately solve for tendencies of +!! \f$U, V, \theta, q_v, q_c, and q_i\f$. +!!\section gen_mynn_bl_driver GSD mynn_bl_driver General Algorithm !> @{ - SUBROUTINE mym_initialize ( & - & kts,kte, & - & dz, dx, zw, & - & u, v, thl, qw, & - & thlsg, qwsg, & -! & ust, rmo, pmz, phh, flt, flq, & - & zi, theta, thetav, sh, sm, & - & ust, rmo, el, & - & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - & INITIALIZE_QKE, & - & spp_pbl,rstoch_col) -! -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - LOGICAL, INTENT(IN) :: INITIALIZE_QKE -! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo, Psig_bl, dx - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 - REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov - REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke + SUBROUTINE mynn_bl_driver( & + &initflag,restart,cycling, & + &delt,dz,dx,znt, & + &u,v,w,th,sqv3D,sqc3D,sqi3D, & + &qnc,qni, & + &qnwfa,qnifa,ozone, & + &p,exner,rho,T3D, & + &xland,ts,qsfc,ps, & + &ust,ch,hfx,qfx,rmol,wspd, & + &uoce,voce, & !ocean current + &vdfg, & !Katata-added for fog dep + &Qke,qke_adv, & + &bl_mynn_tkeadvect,sh3d, & - REAL, DIMENSION(kts:kte) :: & - &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& - &gm,gh,sm,sh,qkw,vt,vq - INTEGER :: k,l,lmax - REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq - REAL :: zi - REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg + &nchem,kdvel,ndvel, & !Smoke/Chem variables + &chem3d, vdep, & + &rrfs_smoke, & ! flag for Smoke + &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs + &mix_chem,fire_turb, & ! end smoke/chem variables - REAL, DIMENSION(kts:kte) :: rstoch_col - INTEGER ::spp_pbl + &Tsq,Qsq,Cov, & + &RUBLTEN,RVBLTEN,RTHBLTEN, & + &RQVBLTEN,RQCBLTEN,RQIBLTEN, & + &RQNCBLTEN,RQNIBLTEN, & + &RQNWFABLTEN,RQNIFABLTEN,DOZONE, & + &exch_h,exch_m, & + &Pblh,kpbl, & + &el_pbl, & + &dqke,qWT,qSHEAR,qBUOY,qDISS, & !TKE BUDGET + &bl_mynn_tkebudget, & + &bl_mynn_cloudpdf, & + &bl_mynn_mixlength, & + &icloud_bl,qc_bl,qi_bl,cldfra_bl,& + &closure, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &bl_mynn_output, & + &bl_mynn_cloudmix,bl_mynn_mixqt, & + &edmf_a,edmf_w,edmf_qt, & + &edmf_thl,edmf_ent,edmf_qc, & + &sub_thl3D,sub_sqv3D, & + &det_thl3D,det_sqv3D, & + &nupdraft,maxMF,ktop_plume, & + &spp_pbl,pattern_spp_pbl, & + &RTHRATEN, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) + +!------------------------------------------------------------------- -!> - At first ql, vt and vq are set to zero. - DO k = kts,kte - ql(k) = 0.0 - vt(k) = 0.0 - vq(k) = 0.0 - END DO -! -!> - Call mym_level2() to calculate the stability functions at level 2. - CALL mym_level2 ( kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & thlsg, qwsg, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -! ** Preliminary setting ** + INTEGER, INTENT(in) :: initflag + !INPUT NAMELIST OPTIONS: + LOGICAL, INTENT(IN) :: restart,cycling + LOGICAL, INTENT(in) :: bl_mynn_tkebudget + INTEGER, INTENT(in) :: bl_mynn_cloudpdf + INTEGER, INTENT(in) :: bl_mynn_mixlength + INTEGER, INTENT(in) :: bl_mynn_edmf + LOGICAL, INTENT(in) :: bl_mynn_tkeadvect + INTEGER, INTENT(in) :: bl_mynn_edmf_mom + INTEGER, INTENT(in) :: bl_mynn_edmf_tke + INTEGER, INTENT(in) :: bl_mynn_mixscalars + INTEGER, INTENT(in) :: bl_mynn_output + INTEGER, INTENT(in) :: bl_mynn_cloudmix + INTEGER, INTENT(in) :: bl_mynn_mixqt + INTEGER, INTENT(in) :: icloud_bl + REAL, INTENT(in) :: closure - el (kts) = 0.0 - IF (INITIALIZE_QKE) THEN - !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) - qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0) - DO k = kts+1,kte - !qke(k) = 0.0 - !linearly taper off towards top of pbl - qke(k)=qke(kts)*MAX((ust*700. - zw(k))/(MAX(ust,0.01)*700.), 0.01) - ENDDO - ENDIF -! - phm = phh*b2 / ( b1*pmz )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) -! - DO k = kts+1,kte - vkz = vk*zw(k) - el (k) = vkz/( 1.0 + vkz/100.0 ) -! qke(k) = 0.0 -! - tsq(k) = 0.0 - qsq(k) = 0.0 - cov(k) = 0.0 - END DO -! -! ** Initialization with an iterative manner ** -! ** lmax is the iteration count. This is arbitrary. ** - lmax = 5 -! - DO l = 1,lmax -! -!> - call mym_length() to calculate the master length scale. - CALL mym_length ( & - & kts,kte, & - & dz, dx, zw, & - & rmo, flt, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) -! - DO k = kts+1,kte - elq = el(k)*qkw(k) - pdk(k) = elq*( sm(k)*gm (k)+& - &sh(k)*gh (k) ) - pdt(k) = elq* sh(k)*dtl(k)**2 - pdq(k) = elq* sh(k)*dqw(k)**2 - pdc(k) = elq* sh(k)*dtl(k)*dqw(k) - END DO -! -! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = vk*0.5*dz(kts) - elv = 0.5*( el(kts+1)+el(kts) ) / vkz - IF (INITIALIZE_QKE)THEN - !qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) - qke(kts) = 1.0 * MAX(ust,0.02)**2 * ( b1*pmz*elv )**(2.0/3.0) - ENDIF + LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + FLAG_QNWFA,FLAG_QNIFA - phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) + LOGICAL, INTENT(IN) :: mix_chem,fire_turb - DO k = kts+1,kte-1 - b1l = b1*0.25*( el(k+1)+el(k) ) - !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) - !add MIN to limit unreasonable QKE - tmpq=MIN(MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.) -! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) - IF (INITIALIZE_QKE)THEN - qke(k) = tmpq**twothirds - ENDIF + INTEGER,INTENT(in) :: & + & IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE - IF ( qke(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) - END IF +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO +! initflag > 0 for TRUE +! else for FALSE +! closure : <= 2.5; Level 2.5 +! 2.5< and <3; Level 2.6 +! = 3; Level 3 + + REAL, INTENT(in) :: delt +!WRF +! REAL, INTENT(in) :: dx +!END WRF +!FV3 + REAL, DIMENSION(IMS:IME), INTENT(in) :: dx +!END FV3 + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz,& + &u,v,w,th,sqv3D,p,exner,rho,T3D + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in)::& + &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone + REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust,& + &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - END DO + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &Qke,Tsq,Qsq,Cov,qke_adv !ACF for QKE advection -!! qke(kts)=qke(kts+1) -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& + &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & + &RQNWFABLTEN,RQNIFABLTEN + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE - IF (INITIALIZE_QKE)THEN - qke(kts)=0.5*(qke(kts)+qke(kts+1)) - qke(kte)=qke(kte-1) - ENDIF - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) - cov(kte)=cov(kte-1) + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN -! -! RETURN + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & + &exch_h,exch_m - END SUBROUTINE mym_initialize -!> @} - -! -! ================================================================== -! SUBROUTINE mym_level2: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: -! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) -! dqw(nx,nz,ny) : Vertical gradient of Q_w -! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) -! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) -! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) -! sm (nx,nz,ny) : Stability function for momentum, at Level 2 -! sh (nx,nz,ny) : Stability function for heat, at Level 2 -! -! These are defined on the walls of the grid boxes. -! + !These 10 arrays are only allocated when bl_mynn_output > 0 + REAL, DIMENSION(:,:), OPTIONAL, INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the level 2, non-dimensional wind shear -!! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as -!! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$. -!!\param kts horizontal dimension -!!\param kte vertical dimension -!!\param dz vertical grid spacings (\f$m\f$) -!!\param u west-east component of the horizontal wind (\f$m s^{-1}\f$) -!!\param v south-north component of the horizontal wind (\f$m s^{-1}\f$) -!!\param thl liquid water potential temperature -!!\param qw total water content \f$Q_w\f$ -!!\param ql liquid water content (\f$kg kg^{-1}\f$) -!!\param vt -!!\param vq -!!\param dtl vertical gradient of \f$\theta_l\f$ (\f$K m^{-1}\f$) -!!\param dqw vertical gradient of \f$Q_w\f$ -!!\param dtv vertical gradient of \f$\theta_V\f$ (\f$K m^{-1}\f$) -!!\param gm \f$G_M\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) -!!\param gh \f$G_H\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) -!!\param sm stability function for momentum, at Level 2 -!!\param sh stability function for heat, at Level 2 -!!\section gen_mym_level2 GSD MYNN-EDMF mym_level2 General Algorithm -!! @ { - SUBROUTINE mym_level2 (kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & thlsg, qwsg, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -!------------------------------------------------------------------- +! REAL, DIMENSION(IMS:IME,KMS:KME) :: & +! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - INTEGER, INTENT(IN) :: kts,kte + REAL, DIMENSION(IMS:IME), INTENT(inout) :: Pblh,rmol -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif + REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& - thetav,thlsg,qwsg - REAL, DIMENSION(kts:kte), INTENT(out) :: & - &dtl,dqw,dtv,gm,gh,sm,sh + INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: & + &KPBL,nupdraft,ktop_plume - INTEGER :: k + REAL, DIMENSION(IMS:IME), INTENT(OUT) :: & + &maxmf - REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& - &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &el_pbl - REAL :: a2fac + REAL, DIMENSION(:,:), INTENT(out) :: & + &qWT,qSHEAR,qBUOY,qDISS,dqke + ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. + ! 1D (local) budget arrays are used for passing between subroutines. + REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat -! ev = 2.5e6 -! tv0 = 0.61*tref -! tv1 = 1.61*tref -! gtr = 9.81/tref -! - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /a2* f1/f2 - shc = 3.0*a2*( g1+g2 ) -! - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 -! - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - dtz = ( thl(k)-thl(k-1) )/( dzk ) - !Alternatively, use SGS clouds for thl - !dtz = ( thlsg(k)-thlsg(k-1) )/( dzk ) - dqz = ( qw(k)-qw(k-1) )/( dzk ) - !Alternatively, use SGS clouds for qw - !dqz = ( qwsg(k)-qwsg(k-1) )/( dzk ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 - vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q - dtq = vtt*dtz +vqq*dqz - !Alternatively, use theta-v without the SGS clouds - !dtq = ( thetav(k)-thetav(k-1) )/( dzk ) -! - dtl(k) = dtz - dqw(k) = dqz - dtv(k) = dtq -!? dtv(i,j,k) = dtz +tv0*dqz -!? : +( ev/pi0(i,j,k)-tv1 ) -!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) -! - gm (k) = duz - gh (k) = -dtq*gtr -! -! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - - !a2fac is needed for the Canuto/Kitamura mod - IF (CKmod .eq. 1) THEN - a2fac = 1./(1. + MAX(ri,0.0)) - ELSE - a2fac = 1. - ENDIF - - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /(a2*a2fac)* f1/f2 - shc = 3.0*(a2*a2fac)*( g1+g2 ) - - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 - -! ** Flux Richardson number ** - rf = MIN( ri1*( ri + ri2-SQRT(ri**2 - ri3*ri + ri4) ), rfc ) -! - sh (k) = shc*( rfc-rf )/( 1.0-rf ) - sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) - END DO -! -! RETURN - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif + REAL, DIMENSION(IMS:IME,KMS:KME) :: Sh3D - END SUBROUTINE mym_level2 -!! @} + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &qc_bl,qi_bl,cldfra_bl + REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& + qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old -! ================================================================== -! SUBROUTINE mym_length: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: see subroutine mym_initialize -! -! Work arrays: -! elt(nx,ny) : Length scale depending on the PBL depth (m) -! vsc(nx,ny) : Velocity scale q_c (m/s) -! at first, used for computing elt -! -! NOTE: the mixing lengths are meant to be calculated at the full- -! sigmal levels (or interfaces beween the model layers). -! -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the mixing lengths. - SUBROUTINE mym_length ( & - & kts,kte, & - & dz, dx, zw, & - & rmo, flt, flq, & - & vt, vq, & - & u1, v1, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) +! smoke/chemical arrays + INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel + LOGICAL, OPTIONAL, INTENT(IN ) :: rrfs_smoke +! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d +! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep + REAL, DIMENSION( :,:,: ), INTENT(INOUT), optional :: chem3d + REAL, DIMENSION( :,: ), INTENT(IN), optional :: vdep + REAL, DIMENSION( : ), INTENT(IN), optional :: frp,EMIS_ANT_NO -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,dx - REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 - REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el - REAL, DIMENSION(kts:kte), INTENT(in) :: dtv - - REAL :: elt,vsc - - REAL, DIMENSION(kts:kte), INTENT(IN) :: theta - REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg - - ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE - ! MIXING LENGTHS: - REAL :: cns, & !< for surface layer (els) in stable conditions - alp1, & !< for turbulent length scale (elt) - alp2, & !< for buoyancy length scale (elb) - alp3, & !< for buoyancy enhancement factor of elb - alp4, & !< for surface layer (els) in unstable conditions - alp5, & !< for BouLac mixing length or above PBLH - alp6 !< for mass-flux/ - - !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. - !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH - !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES - !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - REAL, PARAMETER :: minzi = 300. !< min mixed-layer height - REAL, PARAMETER :: maxdz = 750. !< max (half) transition layer depth - !! =0.3*2500 m PBLH, so the transition - !! layer stops growing for PBLHs > 2.5 km. - REAL, PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth - - !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - REAL, PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) - REAL, PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) - REAL :: z_m - + REAL, DIMENSION(KTS:KTE ,nchem) :: chem1 + REAL, DIMENSION(KTS:KTE+1,nchem) :: s_awchem1 + REAL, DIMENSION(its:ite) :: vd1 + INTEGER :: ic +!local vars + INTEGER :: ITF,JTF,KTF, IMD,JMD INTEGER :: i,j,k - REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, & - & els1,elf,el_stab,el_unstab,el_mf,el_stab_mf,elb_mf, & - & PBLH_PLUS_ENT,Uonset,Ugrid,el_les - REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud + REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& + &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + &Vt, Vq, sgm, thlsg, sqwsg + REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& + &qke1,tsq1,qsq1,cov1,sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & + &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1,dozone1 -! tv0 = 0.61*tref -! gtr = 9.81/tref + !mass-flux variables + REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& + edmf_ent1,edmf_qc1 + REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,& + edmf_ent_dd1,edmf_qc_dd1 + REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & + det_thl,det_sqv,det_sqc,det_u,det_v + REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& + s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& + s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 + REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1,& + sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - SELECT CASE(bl_mynn_mixlength) + REAL, DIMENSION(KTS:KTE+1) :: zw + REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& + & afk,abk,ts_decay, qc_bl2, qi_bl2, & + & th_sfc,ztop_plume,sqc9,sqi9 - CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac + !top-down diffusion + REAL, DIMENSION(ITS:ITE) :: maxKHtopdown + REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD - cns = 2.7 - alp1 = 0.23 - alp2 = 1.0 - alp3 = 5.0 - alp4 = 100. - alp5 = 0.2 + LOGICAL :: INITIALIZE_QKE - ! Impose limits on the height integration for elt and the transition layer depth - zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth + ! Stochastic fields + INTEGER, INTENT(IN) ::spp_pbl + REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) ::rstoch_col - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - END DO + ! Substepping TKE + INTEGER :: nsub + real :: delt2 - elt = 1.0e-5 - vsc = 1.0e-5 + IF ( debug_code ) THEN + if (idbg .lt. ime) then + print*,'in MYNN driver; at beginning' + print*," th(1:5)=",th(idbg,1:5) + print*," u(1:5)=",u(idbg,1:5) + print*," v(1:5)=",v(idbg,1:5) + print*," w(1:5)=",w(idbg,1:5) + print*," sqv(1:5)=",sqv3D(idbg,1:5) + print*," p(1:5)=",p(idbg,1:5) + print*," rho(1:5)=",rho(idbg,1:5) + print*," xland=",xland(idbg)," u*=",ust(idbg), & + &" ts=",ts(idbg)," qsfc=",qsfc(idbg), & + &" z/L=",0.5*dz(idbg,1)*rmol(idbg)," ps=",ps(idbg),& + &" hfx=",hfx(idbg)," qfx=",qfx(idbg), & + &" wspd=",wspd(idbg)," znt=",znt(idbg) + endif + ENDIF - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO +!*** Begin debugging + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 +!*** End debugging - elt = alp1*elt/vsc - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) +!WRF +! JTF=MIN0(JTE,JDE-1) +! ITF=MIN0(ITE,IDE-1) +! KTF=MIN0(KTE,KDE-1) +!FV3 + JTF=JTE + ITF=ITE + KTF=KTE - ! ** Strictly, el(i,k=1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) + IF (bl_mynn_output > 0) THEN !research mode + edmf_a(its:ite,kts:kte)=0. + edmf_w(its:ite,kts:kte)=0. + edmf_qt(its:ite,kts:kte)=0. + edmf_thl(its:ite,kts:kte)=0. + edmf_ent(its:ite,kts:kte)=0. + edmf_qc(its:ite,kts:kte)=0. + sub_thl3D(its:ite,kts:kte)=0. + sub_sqv3D(its:ite,kts:kte)=0. + det_thl3D(its:ite,kts:kte)=0. + det_sqv3D(its:ite,kts:kte)=0. - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels + !edmf_a_dd(its:ite,kts:kte)=0. + !edmf_w_dd(its:ite,kts:kte)=0. + !edmf_qt_dd(its:ite,kts:kte)=0. + !edmf_thl_dd(its:ite,kts:kte)=0. + !edmf_ent_dd(its:ite,kts:kte)=0. + !edmf_qc_dd(its:ite,kts:kte)=0. + ENDIF + ktop_plume(its:ite)=0 !int + nupdraft(its:ite)=0 !int + maxmf(its:ite)=0. + maxKHtopdown(its:ite)=0. - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & - & *( 1.0 + alp3/alp2*& - &SQRT( vsc/( bv*elt ) ) ) - elf = alp2 * qkw(k)/bv + ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS +!> - Within the MYNN-EDMF, there is a dependecy check for the first time step, +!! If true, a three-dimensional initialization loop is entered. Within this loop, +!! several arrays are initialized and k-oriented (vertical) subroutines are called +!! at every i and j point, corresponding to the x- and y- directions, respectively. + IF (initflag > 0 .and. .not.restart) THEN - ELSE - elb = 1.0e10 - elf = elb - ENDIF + !Test to see if we want to initialize qke + IF ( (restart .or. cycling)) THEN + IF (MAXVAL(QKE(its:ite,kts)) < 0.0002) THEN + INITIALIZE_QKE = .TRUE. + !print*,"QKE is too small, must initialize" + ELSE + INITIALIZE_QKE = .FALSE. + !print*,"Using background QKE, will not initialize" + ENDIF + ELSE ! not cycling or restarting: + INITIALIZE_QKE = .TRUE. + !print*,"not restart nor cycling, must initialize QKE" + ENDIF + + if (.not.restart .or. .not.cycling) THEN + Sh3D(its:ite,kts:kte)=0. + el_pbl(its:ite,kts:kte)=0. + tsq(its:ite,kts:kte)=0. + qsq(its:ite,kts:kte)=0. + cov(its:ite,kts:kte)=0. + cldfra_bl(its:ite,kts:kte)=0. + qc_bl(its:ite,kts:kte)=0. + qke(its:ite,kts:kte)=0. + else + qc_bl1D(kts:kte)=0.0 + qi_bl1D(kts:kte)=0.0 + cldfra_bl1D(kts:kte)=0.0 + end if + dqc1(kts:kte)=0.0 + dqi1(kts:kte)=0.0 + dqni1(kts:kte)=0.0 + dqnc1(kts:kte)=0.0 + dqnwfa1(kts:kte)=0.0 + dqnifa1(kts:kte)=0.0 + dozone1(kts:kte)=0.0 + qc_bl1D_old(kts:kte)=0.0 + cldfra_bl1D_old(kts:kte)=0.0 + edmf_a1(kts:kte)=0.0 + edmf_w1(kts:kte)=0.0 + edmf_qc1(kts:kte)=0.0 + edmf_a_dd1(kts:kte)=0.0 + edmf_w_dd1(kts:kte)=0.0 + edmf_qc_dd1(kts:kte)=0.0 + sgm(kts:kte)=0.0 + vt(kts:kte)=0.0 + vq(kts:kte)=0.0 - z_m = MAX(0.,zwk - 4.) + DO k=KTS,KTE + DO i=ITS,ITF + exch_m(i,k)=0. + exch_h(i,k)=0. + ENDDO + ENDDO - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 - END IF + IF ( bl_mynn_tkebudget ) THEN + DO k=KTS,KTE + DO i=ITS,ITF + qWT(i,k)=0. + qSHEAR(i,k)=0. + qBUOY(i,k)=0. + qDISS(i,k)=0. + dqke(i,k)=0. + ENDDO + ENDDO + ENDIF - ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: - ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - ! el(k) = elb/( elb/elt+elb/els+1.0 ) + DO i=ITS,ITF + DO k=KTS,KTE !KTF + dz1(k)=dz(i,k) + u1(k) = u(i,k) + v1(k) = v(i,k) + w1(k) = w(i,k) + th1(k)=th(i,k) + tk1(k)=T3D(i,k) + ex1(k)=exner(i,k) + rho1(k)=rho(i,k) + sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) + sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) + thetav(k)=th(i,k)*(1.+0.608*sqv(k)) + IF (icloud_bl > 0) THEN + CLDFRA_BL1D(k)=CLDFRA_BL(i,k) + QC_BL1D(k)=QC_BL(i,k) + QI_BL1D(k)=QI_BL(i,k) + ENDIF + IF (PRESENT(sqi3D) .AND. FLAG_QI ) THEN + sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) + sqw(k)=sqv(k)+sqc(k)+sqi(k) + thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG + IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN + sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) + sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) + ELSE + sqc9=sqc(k) + sqi9=sqi(k) + ENDIF + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 + sqwsg(k)=sqv(k)+sqc9+sqi9 + ELSE + sqi(k)=0.0 + sqw(k)=sqv(k)+sqc(k) + thl(k)=th1(k)-xlvcp/ex1(k)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG + IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN + sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) + sqi9=0.0 + ELSE + sqc9=sqc(k) + sqi9=0.0 + ENDIF + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 + sqwsg(k)=sqv(k)+sqc9+sqi9 + ENDIF + thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + IF (k==kts) THEN + zw(k)=0. + ELSE + zw(k)=zw(k-1)+dz(i,k-1) + ENDIF + IF (INITIALIZE_QKE) THEN + !Initialize tke for initial PBLH calc only - using + !simple PBLH form of Koracin and Berkowicz (1988, BLM) + !to linearly taper off tke towards top of PBL. + qke1(k)=5.*ust(i) * MAX((ust(i)*700. - zw(k))/(MAX(ust(i),0.01)*700.), 0.01) + ELSE + qke1(k)=qke(i,k) + ENDIF + el(k)=el_pbl(i,k) + sh(k)=Sh3D(i,k) + tsq1(k)=tsq(i,k) + qsq1(k)=qsq(i,k) + cov1(k)=cov(i,k) + if (spp_pbl==1) then + rstoch_col(k)=pattern_spp_pbl(i,k) + else + rstoch_col(k)=0.0 + endif - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + ENDDO - END DO + zw(kte+1)=zw(kte)+dz(i,kte) - CASE (1, 2) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH +!> - Call get_pblh() to calculate hybrid (\f$\theta_{vli}-TKE\f$) PBL height. +! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i),thvl, & + & Qke1,zw,dz1,xland(i),KPBL(i)) + +!> - Call scale_aware() to calculate similarity functions for scale-adaptive control +!! (\f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$). + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) + ELSE + Psig_bl(i)=1.0 + Psig_shcu(i)=1.0 + ENDIF - cns = 3.5 - alp1 = 0.21 - alp2 = 0.3 - alp3 = 1.5 - alp4 = 5.0 - alp5 = 0.2 - alp6 = 50. + ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS +!> - Call mym_initialize() to initializes the mixing length, TKE, \f$\theta^{'2}\f$, +!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. These variables are calculated after +!! obtaining prerequisite variables by calling the following subroutines from +!! within mym_initialize(): mym_level2() and mym_length(). + CALL mym_initialize ( & + &kts,kte, & + &dz1, dx(i), zw, & + &u1, v1, thl, sqv, & + &thlsg, sqwsg, & + &PBLH(i), th1, thetav, sh, sm, & + &ust(i), rmol(i), & + &el, Qke1, Tsq1, Qsq1, Cov1, & + &Psig_bl(i), cldfra_bl1D, & + &bl_mynn_mixlength, & + &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& + &INITIALIZE_QKE, & + &spp_pbl,rstoch_col ) - ! Impose limits on the height integration for elt and the transition layer depth - zi2=MAX(zi,200.) !minzi) - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth + IF (.not.restart) THEN + !UPDATE 3D VARIABLES + DO k=KTS,KTE !KTF + el_pbl(i,k)=el(k) + sh3d(i,k)=sh(k) + qke(i,k)=qke1(k) + tsq(i,k)=tsq1(k) + qsq(i,k)=qsq1(k) + cov(i,k)=cov1(k) + ENDDO + !initialize qke_adv array if using advection + IF (bl_mynn_tkeadvect) THEN + DO k=KTS,KTE + qke_adv(i,k)=qke1(k) + ENDDO + ENDIF + ENDIF - qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels - thetaw(kts)=theta(kts) !theta at full-sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) +!*** Begin debugging +! IF(I==IMD .AND. J==JMD)THEN +! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) +! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k) +! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) +! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",Tsq(i,k) +! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) +! ENDIF +!*** End debugging - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - qtke(k) = 0.5*(qkw(k)**2) ! q -> TKE - thetaw(k)= theta(k)*abk + theta(k-1)*afk - END DO + ENDDO !end i-loop - elt = 1.0e-5 - vsc = 1.0e-5 + ENDIF ! end initflag - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO +!> - After initializing all required variables, the regular procedures +!! performed at every time step are ready for execution. + !ACF- copy qke_adv array into qke if using advection + IF (bl_mynn_tkeadvect) THEN + qke=qke_adv + ENDIF - elt = MIN( MAX( alp1*elt/vsc, 10.), 400.) - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird + DO i=ITS,ITF + DO k=KTS,KTE !KTF + !JOE-TKE BUDGET + IF ( bl_mynn_tkebudget ) THEN + dqke(i,k)=qke(i,k) + END IF + IF (icloud_bl > 0) THEN + CLDFRA_BL1D(k)=CLDFRA_BL(i,k) + QC_BL1D(k)=QC_BL(i,k) + QI_BL1D(k)=QI_BL(i,k) + cldfra_bl1D_old(k)=cldfra_bl(i,k) + qc_bl1D_old(k)=qc_bl(i,k) + qi_bl1D_old(k)=qi_bl(i,k) + else + CLDFRA_BL1D(k)=0.0 + QC_BL1D(k)=0.0 + QI_BL1D(k)=0.0 + cldfra_bl1D_old(k)=0.0 + qc_bl1D_old(k)=0.0 + qi_bl1D_old(k)=0.0 + ENDIF + dz1(k)= dz(i,k) + u1(k) = u(i,k) + v1(k) = v(i,k) + w1(k) = w(i,k) + th1(k)= th(i,k) + tk1(k)=T3D(i,k) + p1(k) = p(i,k) + ex1(k)= exner(i,k) + rho1(k)=rho(i,k) + sqv(k)= sqv3D(i,k) !/(1.+qv(i,k)) + sqc(k)= sqc3D(i,k) !/(1.+qv(i,k)) + qv1(k)= sqv(k)/(1.-sqv(k)) + qc1(k)= sqc(k)/(1.-sqv(k)) + dqc1(k)=0.0 + dqi1(k)=0.0 + dqni1(k)=0.0 + dqnc1(k)=0.0 + dqnwfa1(k)=0.0 + dqnifa1(k)=0.0 + dozone1(k)=0.0 + IF(PRESENT(sqi3D) .AND. FLAG_QI)THEN + sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) + qi1(k)= sqi(k)/(1.-sqv(k)) + sqw(k)= sqv(k)+sqc(k)+sqi(k) + thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG + IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN + sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) + sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) + ELSE + sqc9=sqc(k) + sqi9=sqi(k) + ENDIF + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 + sqwsg(k)=sqv(k)+sqc9+sqi9 + ELSE + qi1(k)=0.0 + sqi(k)=0.0 + sqw(k)= sqv(k)+sqc(k) + thl(k)= th1(k)-xlvcp/ex1(k)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG + IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN + sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) + sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) + ELSE + sqc9=sqc(k) + sqi9=0.0 + ENDIF + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 + ENDIF + thetav(k)=th1(k)*(1.+0.608*sqv(k)) + thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) !full-sigma levels + IF (PRESENT(qni) .AND. FLAG_QNI ) THEN + qni1(k)=qni(i,k) + ELSE + qni1(k)=0.0 + ENDIF + IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN + qnc1(k)=qnc(i,k) + ELSE + qnc1(k)=0.0 + ENDIF + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN + qnwfa1(k)=qnwfa(i,k) + ELSE + qnwfa1(k)=0.0 + ENDIF + IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN + qnifa1(k)=qnifa(i,k) + ELSE + qnifa1(k)=0.0 + ENDIF + IF (PRESENT(ozone)) THEN + ozone1(k)=ozone(i,k) + ELSE + ozone1(k)=0.0 + ENDIF + el(k) = el_pbl(i,k) + qke1(k)=qke(i,k) + sh(k) = sh3d(i,k) + tsq1(k)=tsq(i,k) + qsq1(k)=qsq(i,k) + cov1(k)=cov(i,k) + if (spp_pbl==1) then + rstoch_col(k)=pattern_spp_pbl(i,k) + else + rstoch_col(k)=0.0 + endif - ! COMPUTE BouLac mixing length - CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) + !edmf + edmf_a1(k)=0.0 + edmf_w1(k)=0.0 + edmf_qc1(k)=0.0 + s_aw1(k)=0. + s_awthl1(k)=0. + s_awqt1(k)=0. + s_awqv1(k)=0. + s_awqc1(k)=0. + s_awu1(k)=0. + s_awv1(k)=0. + s_awqke1(k)=0. + s_awqnc1(k)=0. + s_awqni1(k)=0. + s_awqnwfa1(k)=0. + s_awqnifa1(k)=0. + ![EWDD] + edmf_a_dd1(k)=0.0 + edmf_w_dd1(k)=0.0 + edmf_qc_dd1(k)=0.0 + sd_aw1(k)=0. + sd_awthl1(k)=0. + sd_awqt1(k)=0. + sd_awqv1(k)=0. + sd_awqc1(k)=0. + sd_awu1(k)=0. + sd_awv1(k)=0. + sd_awqke1(k)=0. + sub_thl(k)=0. + sub_sqv(k)=0. + sub_u(k)=0. + sub_v(k)=0. + det_thl(k)=0. + det_sqv(k)=0. + det_sqc(k)=0. + det_u(k)=0. + det_v(k)=0. - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels + IF (k==kts) THEN + zw(k)=0. + ELSE + zw(k)=zw(k-1)+dz(i,k-1) + ENDIF + ENDDO ! end k - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - !elb = alp2*qkw(k) / bv & ! formulation, - ! & *( 1.0 + alp3/alp2*& ! except keep - ! &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by zwk - elb = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & - & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) - elb = MIN(elb, zwk) - elf = 0.65 * qkw(k)/bv - ELSE - elb = 1.0e10 - elf = elb - ENDIF + !initialize smoke/chem arrays (if used): + IF (rrfs_smoke .or. mix_chem) then + IF (mix_chem ) then + do ic = 1,ndvel + vd1(ic) = vdep(i,ic) !is this correct???? + chem1(kts,ic) = chem3d(i,kts,ic) + s_awchem1(kts,ic)=0. + enddo + do k = kts+1,kte + DO ic = 1,nchem + chem1(k,ic) = chem3d(i,k,ic) + s_awchem1(k,ic)=0. + ENDDO + enddo + ELSE + do ic = 1,ndvel + vd1(ic) = 0. !is this correct??? (ite) or (ndvel) + chem1(kts,ic) = 0. + s_awchem1(kts,ic)=0. + enddo + do k = kts+1,kte + do ic = 1,nchem + chem1(k,ic) = 0. + s_awchem1(k,ic)=0. + enddo + enddo + ENDIF + ENDIF - z_m = MAX(0.,zwk - 4.) + zw(kte+1)=zw(kte)+dz(i,kte) + !EDMF + s_aw1(kte+1)=0. + s_awthl1(kte+1)=0. + s_awqt1(kte+1)=0. + s_awqv1(kte+1)=0. + s_awqc1(kte+1)=0. + s_awu1(kte+1)=0. + s_awv1(kte+1)=0. + s_awqke1(kte+1)=0. + s_awqnc1(kte+1)=0. + s_awqni1(kte+1)=0. + s_awqnwfa1(kte+1)=0. + s_awqnifa1(kte+1)=0. + sd_aw1(kte+1)=0. + sd_awthl1(kte+1)=0. + sd_awqt1(kte+1)=0. + sd_awqv1(kte+1)=0. + sd_awqc1(kte+1)=0. + sd_awu1(kte+1)=0. + sd_awv1(kte+1)=0. + sd_awqke1(kte+1)=0. + IF ( mix_chem ) THEN + DO ic = 1,nchem + s_awchem1(kte+1,ic)=0. + ENDDO + ENDIF - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 - END IF +!> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ +!! PBL height diagnostic. +! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i),thvl,& + & Qke1,zw,dz1,xland(i),KPBL(i)) - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 +!> - Call scale_aware() to calculate the similarity functions, +!! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control +!! the scale-adaptive behaviour for the local and nonlocal +!! components, respectively. + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) + ELSE + Psig_bl(i)=1.0 + Psig_shcu(i)=1.0 + ENDIF - !add blending to use BouLac mixing length in free atmos; - !defined relative to the PBLH (zi) + transition layer (h1) - !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - !try squared-blending - !el_unstab = SQRT( els**2/(1. + (els1**2/elt**2) )) - el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb**2))) - el(k) = MIN (el(k), elf) - el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt + sqcg= 0.0 !ill-defined variable; qcg has been removed + cpm=cp*(1.+0.84*qv1(kts)) + exnerg=(ps(i)/p1000mb)**rcp - ! include scale-awareness, except for original MYNN - el(k) = el(k)*Psig_bl + !----------------------------------------------------- + !ORIGINAL CODE + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! -ch(i)*(sqc(kts) -sqcg ) + !----------------------------------------------------- + ! Katata-added - The deposition velocity of cloud (fog) + ! water is used instead of CH. + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! & +xlvcp*vdfg(i)*(sqc(kts)/exner(i,kts)- sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! & -vdfg(i)*(sqc(kts) - sqcg ) + !----------------------------------------------------- + flqv = qfx(i)/rho1(kts) + flqc = -vdfg(i)*(sqc(kts) - sqcg ) + th_sfc = ts(i)/ex1(kts) - END DO + ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS + flq =flqv+flqc !! LATENT + flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux + fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux - CASE (3) !Local (mostly) mixing length formulation + ! Update 1/L using updated sfc heat flux and friction velocity + rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) + zet = 0.5*dz(i,kts)*rmol(i) + zet = MAX(zet, -20.) + zet = MIN(zet, 20.) + !if(i.eq.idbg)print*,"updated z/L=",zet + if (bl_mynn_stfunc == 0) then + !Original Kansas-type stability functions + if ( zet >= 0.0 ) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet + else + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/SQRT(1.0-cphh_unst*zet) + end if + else + !Updated stability functions (Puhales, 2020) + phi_m = phim(zet) + pmz = phi_m - zet + phh = phih(zet) + end if - Uonset = 3.5 + dz(kts)*0.1 - Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) - cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.21 - alp2 = 0.30 - alp3 = 1.5 - alp4 = 5.0 - alp5 = alp2 !like alp2, but for free atmosphere - alp6 = 50.0 !used for MF mixing length +!> - Call mym_condensation() to calculate the nonconvective component +!! of the subgrid cloud fraction and mixing ratio as well as the functions +!! used to calculate the buoyancy flux. Different cloud PDFs can be +!! selected by use of the namelist parameter \p bl_mynn_cloudpdf. - ! Impose limits on the height integration for elt and the transition layer depth - !zi2=MAX(zi,minzi) - zi2=MAX(zi, 200.) - !h1=MAX(0.3*zi2,mindz) - !h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) - h2=h1*0.5 ! 1/4 transition layer depth + CALL mym_condensation ( kts,kte, & + &dx(i),dz1,zw,thl,sqw,sqv,sqc,sqi,& + &p1,ex1,tsq1,qsq1,cov1, & + &Sh,el,bl_mynn_cloudpdf, & + &qc_bl1D,qi_bl1D,cldfra_bl1D, & + &PBLH(i),HFX(i), & + &Vt, Vq, th1, sgm, rmol(i), & + &spp_pbl, rstoch_col ) - qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-4)) +!> - Add TKE source driven by cloud top cooling +!! Calculate the buoyancy production of TKE from cloud-top cooling when +!! \p bl_mynn_topdown =1. + IF (bl_mynn_topdown.eq.1)then + CALL topdown_cloudrad(kts,kte,dz1,zw, & + &xland(i),kpbl(i),PBLH(i), & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten, & + &maxKHtopdown(i),KHtopdown,TKEprodTD ) + ELSE + maxKHtopdown(i) = 0.0 + KHtopdown(kts:kte) = 0.0 + TKEprodTD(kts:kte) = 0.0 + ENDIF - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE - END DO + IF (bl_mynn_edmf > 0) THEN + !PRINT*,"Calling DMP Mass-Flux: i= ",i + CALL DMP_mf( & + &kts,kte,delt,zw,dz1,p1,rho1, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &u1,v1,w1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,qke1, & + &qnc1,qni1,qnwfa1,qnifa1, & + &ex1,Vt,Vq,sgm, & + &ust(i),flt,fltv,flq,flqv, & + &PBLH(i),KPBL(i),DX(i), & + &xland(i),th_sfc, & + ! now outputs - tendencies + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! outputs - updraft properties + & edmf_a1,edmf_w1,edmf_qt1, & + & edmf_thl1,edmf_ent1,edmf_qc1, & + ! for the solver + & s_aw1,s_awthl1,s_awqt1, & + & s_awqv1,s_awqc1, & + & s_awu1,s_awv1,s_awqke1, & + & s_awqnc1,s_awqni1, & + & s_awqnwfa1,s_awqnifa1, & + & sub_thl,sub_sqv, & + & sub_u,sub_v, & + & det_thl,det_sqv,det_sqc, & + & det_u,det_v, & + ! chem/smoke mixing + & nchem,chem1,s_awchem1, & + & mix_chem, & + & qc_bl1D,cldfra_bl1D, & + & qc_bl1D_old,cldfra_bl1D_old, & + & FLAG_QC,FLAG_QI, & + & FLAG_QNC,FLAG_QNI, & + & FLAG_QNWFA,FLAG_QNIFA, & + & Psig_shcu(i), & + & nupdraft(i),ktop_plume(i), & + & maxmf(i),ztop_plume, & + & spp_pbl,rstoch_col ) + ENDIF - elt = 1.0e-5 - vsc = 1.0e-5 + IF (bl_mynn_edmf_dd == 1) THEN + CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, & + &u1,v1,th1,thl,thetav,tk1, & + sqw,sqv,sqc,rho1,ex1, & + &ust(i),flt,flq, & + &PBLH(i),KPBL(i), & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & + &edmf_thl_dd1,edmf_ent_dd1, & + &edmf_qc_dd1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & + &sd_awqke1, & + &qc_bl1d,cldfra_bl1d, & + &rthraten(i,:) ) + ENDIF - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - PBLH_PLUS_ENT = MAX(zi+h1, 100.) - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. PBLH_PLUS_ENT) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO + !Capability to substep the eddy-diffusivity portion + !do nsub = 1,2 + delt2 = delt !*0.5 !only works if topdown=0 - elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird + CALL mym_turbulence ( & + &kts,kte,closure, & + &dz1, DX(i), zw, & + &u1, v1, thl, thetav, sqc, sqw, & + &thlsg, sqwsg, & + &qke1, tsq1, qsq1, cov1, & + &vt, vq, & + &rmol(i), flt, flq, & + &PBLH(i),th1, & + &Sh,Sm,el, & + &Dfm,Dfh,Dfq, & + &Tcd,Qcd,Pdk, & + &Pdt,Pdq,Pdc, & + &qWT1,qSHEAR1,qBUOY1,qDISS1, & + &bl_mynn_tkebudget, & + &Psig_bl(i),Psig_shcu(i), & + &cldfra_bl1D,bl_mynn_mixlength, & + &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + &TKEprodTD, & + &spp_pbl,rstoch_col) - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) +!> - Call mym_predict() to solve TKE and +!! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ +!! for the following time step. + CALL mym_predict (kts,kte,closure, & + &delt2, dz1, & + &ust(i), flt, flq, pmz, phh, & + &el, dfq, rho1, pdk, pdt, pdq, pdc,& + &Qke1, Tsq1, Qsq1, Cov1, & + &s_aw1, s_awqke1, bl_mynn_edmf_tke,& + &qWT1, qDISS1,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - dzk = 0.5*( dz(k)+dz(k-1) ) - cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) + if (dheat_opt > 0) then + DO k=kts,kte-1 + ! Set max dissipative heating rate to 7.2 K per hour + diss_heat(k) = MIN(MAX(0.75*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) + ENDDO + diss_heat(kte) = 0. + else + diss_heat(1:kte) = 0. + endif - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - !impose min value on bv - bv = MAX( SQRT( gtr*dtv(k) ), 0.001) - !elb_mf = alp2*qkw(k) / bv & - elb_mf = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & - & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) - elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) +!> - Call mynn_tendencies() to solve for tendencies of +!! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. + CALL mynn_tendencies(kts,kte,i, & + &closure, & + &delt, dz1, rho1, & + &u1, v1, th1, tk1, qv1, & + &qc1, qi1, qnc1, qni1, & + &ps(i), p1, ex1, thl, & + &sqv, sqc, sqi, sqw, & + &qnwfa1, qnifa1, ozone1, & + &ust(i),flt,flq,flqv,flqc, & + &wspd(i),uoce(i),voce(i), & + &tsq1, qsq1, cov1, & + &tcd, qcd, & + &dfm, dfh, dfq, & + &Du1, Dv1, Dth1, Dqv1, & + &Dqc1, Dqi1, Dqnc1, Dqni1, & + &Dqnwfa1, Dqnifa1, Dozone1, & + &vdfg(i), diss_heat, & + ! mass flux components + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1, & + sd_awu1,sd_awv1, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) - !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.) - wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird - tau_cloud = MIN(MAX(ctau * wstar/g, 30.), 150.) - !minimize influence of surface heat flux on tau far away from the PBLH. - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - tau_cloud = tau_cloud*(1.-wt) + 50.*wt - elf = MIN(MAX(tau_cloud*SQRT(MIN(qtke(k),40.)), & - & alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk) - !IF (zwk > zi .AND. elf > 400.) THEN - ! ! COMPUTE BouLac mixing length - ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) - ! !elf = alp5*elBLavg0 - ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) - !ENDIF + IF ( mix_chem ) THEN + CALL mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &emis_ant_no(i), & + &frp(i), & + &fire_turb ) + + IF ( PRESENT(chem3d) ) THEN + DO ic = 1,nchem + DO k = kts,kte + chem3d(i,k,ic) = chem1(k,ic) + ENDDO + ENDDO + ENDIF + ENDIF + + CALL retrieve_exchange_coeffs(kts,kte,& + &dfm, dfh, dz1, K_m1, K_h1) - ELSE - ! use version in development for RAP/HRRR 2016 - ! JAYMES- - ! tau_cloud is an eddy turnover timescale; - ! see Teixeira and Cheinet (2004), Eq. 1, and - ! Cheinet and Teixeira (2003), Eq. 7. The - ! coefficient 0.5 is tuneable. Expression in - ! denominator is identical to vsc (a convective - ! velocity scale), except that elt is relpaced - ! by zi, and zero is replaced by 1.0e-4 to - ! prevent division by zero. - !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.) - wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird - tau_cloud = MIN(MAX(ctau * wstar/g, 50.), 200.) - !minimize influence of surface heat flux on tau far away from the PBLH. - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - !tau_cloud = tau_cloud*(1.-wt) + 50.*wt - tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt + !UPDATE 3D ARRAYS + DO k=KTS,KTE !KTF + exch_m(i,k)=K_m1(k) + exch_h(i,k)=K_h1(k) + RUBLTEN(i,k)=du1(k) + RVBLTEN(i,k)=dv1(k) + RTHBLTEN(i,k)=dth1(k) + RQVBLTEN(i,k)=dqv1(k) + IF(bl_mynn_cloudmix > 0)THEN + IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=dqc1(k) + IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=dqi1(k) + ELSE + IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=0. + IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=0. + ENDIF + IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) + ELSE + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=0. + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=0. + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=0. + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=0. + ENDIF + DOZONE(i,k)=DOZONE1(k) - elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk) - !elf = elb - elf = elb !/(1. + (elb/800.)) !bound free-atmos mixing length to < 800 m. - elb_mf = elb - END IF - elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m. -! elb_mf = elb_mf/(1. + (elb_mf/800.)) !bound buoyancy mixing length to < 800 m. - elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below + IF(icloud_bl > 0)THEN + !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS + IF (CLDFRA_BL1D(k) < cldfra_bl1D_old(k)) THEN + !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER + !TIMESCALE, BUT FOR WINDY CONDITIONS, IT IS THE ADVECTIVE + !TIMESCALE. USE THE MINIMUM OF THE TWO. + ts_decay = MIN( 1800., 2.*dx(i)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) + cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) + ! qc_bl2 and qi_bl2 are linked to decay rates + qc_bl2 = MAX(qc_bl1D(k),qc_bl1D_old(k)) + qi_bl2 = MAX(qi_bl1D(k),qi_bl1D_old(k)) + qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-5) * delt/ts_decay)) + qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-6) * delt/ts_decay)) + IF (cldfra_bl(i,k) < 0.005 .OR. & + (qc_bl(i,k) + qi_bl(i,k)) < 1E-9) THEN + CLDFRA_BL(i,k)= 0. + QC_BL(i,k) = 0. + QI_BL(i,k) = 0. + ENDIF + ELSE + qc_bl(i,k)=qc_bl1D(k) + qi_bl(i,k)=qi_bl1D(k) + cldfra_bl(i,k)=cldfra_bl1D(k) + ENDIF + ENDIF - z_m = MAX(0.,zwk - 4.) + el_pbl(i,k)=el(k) + qke(i,k)=qke1(k) + tsq(i,k)=tsq1(k) + qsq(i,k)=qsq1(k) + cov(i,k)=cov1(k) + sh3d(i,k)=sh(k) - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 - END IF + ENDDO !end-k - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + IF ( bl_mynn_tkebudget ) THEN + !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) + !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) + k=kts + qSHEAR1(k)=4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered + qBUOY1(k)=4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered + !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array + DO k = kts,kte-1 + qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z + qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z + qWT(i,k)=qWT1(k) + qDISS(i,k)=qDISS1(k) + dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt + ENDDO + !! Upper boundary conditions + k=kte + qSHEAR(i,k)=0. + qBUOY(i,k)=0. + qWT(i,k)=0. + qDISS(i,k)=0. + dqke(i,k)=0. + ENDIF - ! "el_unstab" = blended els-elt - !el_unstab = els/(1. + (els1/elt)) - !try squared-blending - !el(k) = SQRT( els**2/(1. + (els1**2/elt**2) )) - el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb_mf**2))) - !el(k) = MIN(el_unstab, elb_mf) - el(k) = el(k)*(1.-wt) + elf*wt + !update updraft/downdraft properties + if (bl_mynn_output > 0) THEN !research mode == 1 + if (bl_mynn_edmf > 0) THEN + DO k = kts,kte + edmf_a(i,k)=edmf_a1(k) + edmf_w(i,k)=edmf_w1(k) + edmf_qt(i,k)=edmf_qt1(k) + edmf_thl(i,k)=edmf_thl1(k) + edmf_ent(i,k)=edmf_ent1(k) + edmf_qc(i,k)=edmf_qc1(k) + sub_thl3D(i,k)=sub_thl(k) + sub_sqv3D(i,k)=sub_sqv(k) + det_thl3D(i,k)=det_thl(k) + det_sqv3D(i,k)=det_sqv(k) + ENDDO + endif +! if (bl_mynn_edmf_dd > 0) THEN +! DO k = kts,kte +! edmf_a_dd(i,k)=edmf_a_dd1(k) +! edmf_w_dd(i,k)=edmf_w_dd1(k) +! edmf_qt_dd(i,k)=edmf_qt_dd1(k) +! edmf_thl_dd(i,k)=edmf_thl_dd1(k) +! edmf_ent_dd(i,k)=edmf_ent_dd1(k) +! edmf_qc_dd(i,k)=edmf_qc_dd1(k) +! ENDDO +! ENDIF + ENDIF - ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. - el_les= MIN(els/(1. + (els1/12.)), elb_mf) - el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les + !*** Begin debug prints + IF ( debug_code .and. (i .eq. idbg)) THEN + IF ( ABS(QFX(i))>.001)print*,& + "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) + IF ( ABS(HFX(i))>1100.)print*,& + "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) + DO k = kts,kte + IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) + IF ( ABS(vt(k)) > 0.9 )print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) + IF ( ABS(vq(k)) > 6000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) + IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) + IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) + IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) + IF (icloud_bl > 0) then + IF( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN + PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) + ENDIF + ENDIF - END DO + !IF (I==IMD .AND. J==JMD) THEN + ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) + ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) + ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) + ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) + ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) + ! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i) + !ENDIF + ENDDO !end-k + ENDIF + !*** End debug prints - END SELECT + !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) + ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. + !tke_pbl(i,kts) = 0.5*MAX(qke(i,kts),1.0e-10) + !DO k = kts+1,kte + ! afk = dz1(k)/( dz1(k)+dz1(k-1) ) + ! abk = 1.0 -afk + ! tke_pbl(i,k) = 0.5*MAX(qke(i,k)*abk+qke(i,k-1)*afk,1.0e-3) + !ENDDO + + ENDDO !end i-loop +!ACF copy qke into qke_adv if using advection + IF (bl_mynn_tkeadvect) THEN + qke_adv=qke + ENDIF +!ACF-end #ifdef HARDCODE_VERTICAL # undef kts # undef kte #endif - END SUBROUTINE mym_length + END SUBROUTINE mynn_bl_driver +!> @} -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for -!! integration into the MYNN PBL scheme. WHILE loops were added to reduce the -!! computational expense. This subroutine computes the length scales up and down -!! and then computes the min, average of the up/down length scales, and also -!! considers the distance to the surface. -!\param dlu the distance a parcel can be lifted upwards give a finite -! amount of TKE. -!\param dld the distance a parcel can be displaced downwards given a -! finite amount of TKE. -!\param lb1 the minimum of the length up and length down -!\param lb2 the average of the length up and length down - SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) +!======================================================================= +! SUBROUTINE mym_initialize: ! -! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW -! and modified for integration into the MYNN PBL scheme. -! WHILE loops were added to reduce the computational expense. -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down -! length scales, and also considers the distance to the -! surface. +! Input variables: +! iniflag : <>0; turbulent quantities will be initialized +! = 0; turbulent quantities have been already +! given, i.e., they will not be initialized +! nx, nz : Dimension sizes of the +! x and z directions, respectively +! tref : Reference temperature (K) +! dz(nz) : Vertical grid spacings (m) +! # dz(nz)=dz(nz-1) +! zw(nz+1) : Heights of the walls of the grid boxes (m) +! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) +! exner(nx,nz) : Exner function at zw*h+zg (J/kg K) +! defined by c_p*( p_basic/1000hPa )^kappa +! This is usually computed by integrating +! d(pi0)/dz = -h*g/tref. +! rmo(nx) : Inverse of the Obukhov length (m^(-1)) +! flt, flq(nx) : Turbulent fluxes of potential temperature and +! total water, respectively: +! flt=-u_*Theta_* (K m/s) +! flq=-u_*qw_* (kg/kg m/s) +! ust(nx) : Friction velocity (m/s) +! pmz(nx) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) +! is the first grid point above the surafce, z0 +! the roughness length and zeta=(z1*h+z0)*rmo +! phh(nx) : phi_h at z1*h+z0 +! u, v(nx,nz) : Components of the horizontal wind (m/s) +! thl(nx,nz) : Liquid water potential temperature +! (K) +! qw(nx,nz) : Total water content Q_w (kg/kg) ! -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: k,kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - - !LOCAL VARS - INTEGER :: izz, found - REAL :: dlu,dld - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz +! Output variables: +! ql(nx,nz) : Liquid water content (kg/kg) +! vt, vq(nx,nz) : Functions for computing the buoyancy flux +! qke(nx,nz) : Twice the turbulent kinetic energy q^2 +! (m^2/s^2) +! tsq(nx,nz) : Variance of Theta_l (K^2) +! qsq(nx,nz) : Variance of Q_w +! cov(nx,nz) : Covariance of Theta_l and Q_w (K) +! el(nx,nz) : Master length scale L (m) +! defined on the walls of the grid boxes +! +! Work arrays: see subroutine mym_level2 +! pd?(nx,nz,ny) : Half of the production terms at Level 2 +! defined on the walls of the grid boxes +! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) +! +! # As to dtl, ...gh, see subroutine mym_turbulence. +! +!------------------------------------------------------------------- +!>\ingroup gsd_mynn_edmf +!! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$, +!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. +!!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm +!> @{ + SUBROUTINE mym_initialize ( & + & kts,kte, & + & dz, dx, zw, & + & u, v, thl, qw, & + & thlsg, qwsg, & +! & ust, rmo, pmz, phh, flt, flq, & + & zi, theta, thetav, sh, sm, & + & ust, rmo, el, & + & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & INITIALIZE_QKE, & + & spp_pbl,rstoch_col) +! +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf + LOGICAL, INTENT(IN) :: INITIALIZE_QKE +! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq + REAL, INTENT(IN) :: ust, rmo, Psig_bl, dx + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& + edmf_w1,edmf_a1,edmf_qc1 + REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov + REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu=zw(kte+1)-zw(k)-dz(k)/2. - zzz=0. - zup_inf=0. - beta=g/theta(k) !Buoyancy coefficient + REAL, DIMENSION(kts:kte) :: & + &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& + &gm,gh,sm,sh,qkw,vt,vq + INTEGER :: k,l,lmax + REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq + REAL :: zi + REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg - !print*,"FINDING Dup, k=",k," zw=",zw(k) + REAL, DIMENSION(kts:kte) :: rstoch_col + INTEGER ::spp_pbl - if (k .lt. kte) then !cant integrate upwards from highest level - found = 0 - izz=k - DO WHILE (found .EQ. 0) +!> - At first ql, vt and vq are set to zero. + DO k = kts,kte + ql(k) = 0.0 + vt(k) = 0.0 + vq(k) = 0.0 + END DO +! +!> - Call mym_level2() to calculate the stability functions at level 2. + CALL mym_level2 ( kts,kte, & + & dz, & + & u, v, thl, thetav, qw, & + & thlsg, qwsg, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! +! ** Preliminary setting ** - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k - !print*," ",k,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer k to izz+1 - !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(k)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & - & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(k))then - tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dlu=zzz-dzt+tl - !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF + el (kts) = 0.0 + IF (INITIALIZE_QKE) THEN + !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) + qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0) + DO k = kts+1,kte + !qke(k) = 0.0 + !linearly taper off towards top of pbl + qke(k)=qke(kts)*MAX((ust*700. - zw(k))/(MAX(ust,0.01)*700.), 0.01) + ENDDO + ENDIF +! + phm = phh*b2 / ( b1*pmz )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) +! + DO k = kts+1,kte + vkz = karman*zw(k) + el (k) = vkz/( 1.0 + vkz/100.0 ) +! qke(k) = 0.0 +! + tsq(k) = 0.0 + qsq(k) = 0.0 + cov(k) = 0.0 + END DO +! +! ** Initialization with an iterative manner ** +! ** lmax is the iteration count. This is arbitrary. ** + lmax = 5 +! + DO l = 1,lmax +! +!> - call mym_length() to calculate the master length scale. + CALL mym_length ( & + & kts,kte, & + & dz, dx, zw, & + & rmo, flt, flq, & + & vt, vq, & + & u, v, qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) +! + DO k = kts+1,kte + elq = el(k)*qkw(k) + pdk(k) = elq*( sm(k)*gm(k) + & + & sh(k)*gh(k) ) + pdt(k) = elq* sh(k)*dtl(k)**2 + pdq(k) = elq* sh(k)*dqw(k)**2 + pdc(k) = elq* sh(k)*dtl(k)*dqw(k) + END DO +! +! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = karman*0.5*dz(kts) + elv = 0.5*( el(kts+1)+el(kts) ) / vkz + IF (INITIALIZE_QKE)THEN + !qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) + qke(kts) = 1.0 * MAX(ust,0.02)**2 * ( b1*pmz*elv )**(2.0/3.0) + ENDIF - ENDDO + phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) - endif + DO k = kts+1,kte-1 + b1l = b1*0.25*( el(k+1)+el(k) ) + !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) + !add MIN to limit unreasonable QKE + tmpq=MIN(MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.) +! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) + IF (INITIALIZE_QKE)THEN + qke(k) = tmpq**twothirds + ENDIF - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld=zw(k) - zzz=0. + IF ( qke(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) + END IF - !print*,"FINDING Ddown, k=",k," zwk=",zw(k) - if (k .gt. kts) then !cant integrate downwards from lowest level + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO - found = 0 - izz=k - DO WHILE (found .EQ. 0) + END DO - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(k)*dzt - !print*," ",k,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(k))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & - & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(k)) then - tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dld=zzz-dzt+tl - !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO +!! qke(kts)=qke(kts+1) +!! tsq(kts)=tsq(kts+1) +!! qsq(kts)=qsq(kts+1) +!! cov(kts)=cov(kts+1) - endif + IF (INITIALIZE_QKE)THEN + qke(kts)=0.5*(qke(kts)+qke(kts+1)) + qke(kte)=qke(kte-1) + ENDIF + tsq(kte)=tsq(kte-1) + qsq(kte)=qsq(kte-1) + cov(kte)=cov(kte-1) - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos - lb1 = min(dlu,dld) !minimum - !JOE-fight floating point errors - dlu=MAX(0.1,MIN(dlu,1000.)) - dld=MAX(0.1,MIN(dld,1000.)) - lb2 = sqrt(dlu*dld) !average - biased towards smallest - !lb2 = 0.5*(dlu+dld) !average - - if (k .eq. kte) then - lb1 = 0. - lb2 = 0. - endif - !print*,"IN MYNN-BouLac",k,lb1 - !print*,"IN MYNN-BouLac",k,dld,dlu - - END SUBROUTINE boulac_length0 +! +! RETURN + END SUBROUTINE mym_initialize +!> @} + +! ! ================================================================== +! SUBROUTINE mym_level2: +! +! Input variables: see subroutine mym_initialize +! +! Output variables: +! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) +! dqw(nx,nz,ny) : Vertical gradient of Q_w +! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) +! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) +! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) +! sm (nx,nz,ny) : Stability function for momentum, at Level 2 +! sh (nx,nz,ny) : Stability function for heat, at Level 2 +! +! These are defined on the walls of the grid boxes. +! + !>\ingroup gsd_mynn_edmf -!! This subroutine was taken from the BouLac scheme in WRF-ARW -!! and modified for integration into the MYNN PBL scheme. -!! WHILE loops were added to reduce the computational expense. -!! This subroutine computes the length scales up and down -!! and then computes the min, average of the up/down -!! length scales, and also considers the distance to the -!! surface. - SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down +!! This subroutine calculates the level 2, non-dimensional wind shear +!! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as +!! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$. +!!\param kts horizontal dimension +!!\param kte vertical dimension +!!\param dz vertical grid spacings (\f$m\f$) +!!\param u west-east component of the horizontal wind (\f$m s^{-1}\f$) +!!\param v south-north component of the horizontal wind (\f$m s^{-1}\f$) +!!\param thl liquid water potential temperature +!!\param qw total water content \f$Q_w\f$ +!!\param ql liquid water content (\f$kg kg^{-1}\f$) +!!\param vt +!!\param vq +!!\param dtl vertical gradient of \f$\theta_l\f$ (\f$K m^{-1}\f$) +!!\param dqw vertical gradient of \f$Q_w\f$ +!!\param dtv vertical gradient of \f$\theta_V\f$ (\f$K m^{-1}\f$) +!!\param gm \f$G_M\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) +!!\param gh \f$G_H\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) +!!\param sm stability function for momentum, at Level 2 +!!\param sh stability function for heat, at Level 2 +!!\section gen_mym_level2 GSD MYNN-EDMF mym_level2 General Algorithm +!! @ { + SUBROUTINE mym_level2 (kts,kte, & + & dz, & + & u, v, thl, thetav, qw, & + & thlsg, qwsg, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + INTEGER, INTENT(IN) :: kts,kte - !LOCAL VARS - INTEGER :: iz, izz, found - REAL, DIMENSION(kts:kte) :: dlu,dld - REAL, PARAMETER :: Lmax=2000. !soft limit - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif - !print*,"IN MYNN-BouLac",kts, kte + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& + thetav,thlsg,qwsg + REAL, DIMENSION(kts:kte), INTENT(out) :: & + &dtl,dqw,dtv,gm,gh,sm,sh - do iz=kts,kte + INTEGER :: k - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)/2. - zzz=0. - zup_inf=0. - beta=g/theta(iz) !Buoyancy coefficient + REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& + &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf - !print*,"FINDING Dup, k=",iz," zw=",zw(iz) + REAL :: a2fac - if (iz .lt. kte) then !cant integrate upwards from highest level +! ev = 2.5e6 +! tv0 = 0.61*tref +! tv1 = 1.61*tref +! gtr = 9.81/tref +! + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /a2* f1/f2 + shc = 3.0*a2*( g1+g2 ) +! + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 +! + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + dtz = ( thl(k)-thl(k-1) )/( dzk ) + !Alternatively, use SGS clouds for thl + !dtz = ( thlsg(k)-thlsg(k-1) )/( dzk ) + dqz = ( qw(k)-qw(k-1) )/( dzk ) + !Alternatively, use SGS clouds for qw + !dqz = ( qwsg(k)-qwsg(k-1) )/( dzk ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 + vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q + dtq = vtt*dtz +vqq*dqz + !Alternatively, use theta-v without the SGS clouds + !dtq = ( thetav(k)-thetav(k-1) )/( dzk ) +! + dtl(k) = dtz + dqw(k) = dqz + dtv(k) = dtq +!? dtv(i,j,k) = dtz +tv0*dqz +!? : +( xlv/pi0(i,j,k)-tv1 ) +!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) +! + gm (k) = duz + gh (k) = -dtq*gtr +! +! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) - found = 0 - izz=iz - DO WHILE (found .EQ. 0) + !a2fac is needed for the Canuto/Kitamura mod + IF (CKmod .eq. 1) THEN + a2fac = 1./(1. + MAX(ri,0.0)) + ELSE + a2fac = 1. + ENDIF - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz - !print*," ",iz,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer iz to izz+1 - !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(iz)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & - & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(iz))then - tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dlu(iz)=zzz-dzt+tl - !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /(a2*a2fac)* f1/f2 + shc = 3.0*(a2*a2fac)*( g1+g2 ) - ENDDO + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld(iz)=zw(iz) - zzz=0. +! ** Flux Richardson number ** + rf = MIN( ri1*( ri + ri2-SQRT(ri**2 - ri3*ri + ri4) ), rfc ) +! + sh (k) = shc*( rfc-rf )/( 1.0-rf ) + sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) + END DO +! +! RETURN - !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) - if (iz .gt. kts) then !cant integrate downwards from lowest level +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif - found = 0 - izz=iz - DO WHILE (found .EQ. 0) + END SUBROUTINE mym_level2 +!! @} - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(iz)*dzt - !print*," ",iz,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(iz))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & - & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(iz)) then - tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dld(iz)=zzz-dzt+tl - !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos - lb1(iz) = min(dlu(iz),dld(iz)) !minimum - !JOE-fight floating point errors - dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) - dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) - lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest - !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average - - !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). - lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) - lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) - - if (iz .eq. kte) then - lb1(kte) = lb1(kte-1) - lb2(kte) = lb2(kte-1) - endif - !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) - !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) - - ENDDO - - END SUBROUTINE boulac_length -! ! ================================================================== -! SUBROUTINE mym_turbulence: +! SUBROUTINE mym_length: ! ! Input variables: see subroutine mym_initialize -! closure : closure level (2.5, 2.6, or 3.0) -! -! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. ! ! Output variables: see subroutine mym_initialize -! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, -! divided by dz (not dz*h(i,j)) (m/s) -! dfh(nx,nz,ny) : Diffusivity coefficient for heat, -! divided by dz (not dz*h(i,j)) (m/s) -! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, -! divided by dz (not dz*h(i,j)) (m/s) -! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l -! (K/s) -! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w -! (kg/kg s) -! pd?(nx,nz,ny) : Half of the production terms -! -! Only tcd and qcd are defined at the center of the grid boxes -! -! # DO NOT forget that tcd and qcd are added on the right-hand side -! of the equations for Theta_l and Q_w, respectively. ! -! Work arrays: see subroutine mym_initialize and level2 +! Work arrays: +! elt(nx,ny) : Length scale depending on the PBL depth (m) +! vsc(nx,ny) : Velocity scale q_c (m/s) +! at first, used for computing elt ! -! # dtl, dqw, dtv, gm and gh are allowed to share storage units with -! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. +! NOTE: the mixing lengths are meant to be calculated at the full- +! sigmal levels (or interfaces beween the model layers). ! !>\ingroup gsd_mynn_edmf -!! This subroutine calculates the vertical diffusivity coefficients and the -!! production terms for the turbulent quantities. -!>\section gen_mym_turbulence GSD mym_turbulence General Algorithm -!! Two subroutines mym_level2() and mym_length() are called within this -!!subrouine to collect variable to carry out successive calculations: -!! - mym_level2() calculates the level 2 nondimensional wind shear \f$G_M\f$ -!! and vertical temperature gradient \f$G_H\f$ as well as the level 2 stability -!! functions \f$S_h\f$ and \f$S_m\f$. -!! - mym_length() calculates the mixing lengths. -!! - The stability criteria from Helfand and Labraga (1989) are applied. -!! - The stability functions for level 2.5 or level 3.0 are calculated. -!! - If level 3.0 is used, counter-gradient terms are calculated. -!! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$ -!! are calculated. -!! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated. -!! - TKE budget terms are calculated (if the namelist parameter \p bl_mynn_tkebudget -!! is set to True) - SUBROUTINE mym_turbulence ( & - & kts,kte, & - & closure, & - & dz, dx, zw, & - & u, v, thl, thetav, ql, qw, & - & thlsg, qwsg, & - & qke, tsq, qsq, cov, & - & vt, vq, & - & rmo, flt, flq, & - & zi,theta, & - & sh, sm, & - & El, & - & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & - & bl_mynn_tkebudget, & - & Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - & TKEprodTD, & - & spp_pbl,rstoch_col) - +!! This subroutine calculates the mixing lengths. + SUBROUTINE mym_length ( & + & kts,kte, & + & dz, dx, zw, & + & rmo, flt, flq, & + & vt, vq, & + & u1, v1, qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + !------------------------------------------------------------------- -! + INTEGER, INTENT(IN) :: kts,kte #ifdef HARDCODE_VERTICAL @@ -1637,3992 +2053,3639 @@ SUBROUTINE mym_turbulence ( & #endif INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL, INTENT(IN) :: closure - REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& - &TKEprodTD,thlsg,qwsg - - REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& - &pdk,pdt,pdq,pdc,tcd,qcd,el - - REAL, DIMENSION(kts:kte), INTENT(inout) :: & - qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new - REAL :: dudz,dvdz,dTdz,& - upwp,vpwp,Tpwp - INTEGER, INTENT(in) :: bl_mynn_tkebudget - - REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,dx + REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& + edmf_w1,edmf_a1,edmf_qc1 + REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el + REAL, DIMENSION(kts:kte), INTENT(in) :: dtv - INTEGER :: k -! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c - REAL :: e6c,dzk,afk,abk,vtt,vqq,& - &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh + REAL :: elt,vsc - REAL :: zi, cldavg - REAL, DIMENSION(kts:kte), INTENT(in) :: theta + REAL, DIMENSION(kts:kte), INTENT(IN) :: theta + REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg - REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod + ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE + ! MIXING LENGTHS: + REAL :: cns, & !< for surface layer (els) in stable conditions + alp1, & !< for turbulent length scale (elt) + alp2, & !< for buoyancy length scale (elb) + alp3, & !< for buoyancy enhancement factor of elb + alp4, & !< for surface layer (els) in unstable conditions + alp5, & !< for BouLac mixing length or above PBLH + alp6 !< for mass-flux/ - REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min + !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. + !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH + !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES + !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). + REAL, PARAMETER :: minzi = 300. !< min mixed-layer height + REAL, PARAMETER :: maxdz = 750. !< max (half) transition layer depth + !! =0.3*2500 m PBLH, so the transition + !! layer stops growing for PBLHs > 2.5 km. + REAL, PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth - DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel - DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv - DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden + !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER + REAL, PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) + REAL, PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) + REAL :: z_m -! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum - REAL, PARAMETER :: Prlimit = 10.0 + INTEGER :: i,j,k + REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, & + & els1,elf,el_stab,el_unstab,el_mf,el_stab_mf,elb_mf, & + & PBLH_PLUS_ENT,Uonset,Ugrid,el_les + REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud -! ! tv0 = 0.61*tref ! gtr = 9.81/tref -! -! cc2 = 1.0-c2 -! cc3 = 1.0-c3 -! e1c = 3.0*a2*b2*cc3 -! e2c = 9.0*a1*a2*cc2 -! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) -! e4c = 12.0*a1*a2*cc2 -! e5c = 6.0*a1*a1 -! - CALL mym_level2 (kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & thlsg, qwsg, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! - CALL mym_length ( & - & kts,kte, & - & dz, dx, zw, & - & rmo, flt, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf ) -! + SELECT CASE(bl_mynn_mixlength) - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - elsq = el (k)**2 - q3sq = qkw(k)**2 - q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) + CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac - sh20 = MAX(sh(k), 1e-5) - sm20 = MAX(sm(k), 1e-5) - sh(k)= MAX(sh(k), 1e-5) + cns = 2.7 + alp1 = 0.23 + alp2 = 1.0 + alp3 = 5.0 + alp4 = 100. + alp5 = 0.2 - !Canuto/Kitamura mod - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - ! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - IF (CKmod .eq. 1) THEN - a2fac = 1./(1. + MAX(ri,0.0)) - ELSE - a2fac = 1. - ENDIF - !end Canuto/Kitamura mod + ! Impose limits on the height integration for elt and the transition layer depth + zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth - !level 2.0 Prandtl number - !Prnum = MIN(sm20/sh20, 4.0) - !The form of Zilitinkevich et al. (2006) but modified - !half-way towards Esau and Grachev (2007, Wind Eng) - !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit) - Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit) - !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit) -! -! Modified: Dec/22/2005, from here, (dlsq -> elsq) - gmel = gm (k)*elsq - ghel = gh (k)*elsq -! Modified: Dec/22/2005, up to here - - ! Level 2.0 debug prints - IF ( debug_code ) THEN - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + END DO -! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** + elt = 1.0e-5 + vsc = 1.0e-5 -!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -!JOE-end + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO - IF ( q3sq .LT. q2sq ) THEN - !Apply Helfand & Labraga mod - qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) -! - !Use level 2.5 stability functions - !e1 = q3sq - e1c*ghel*a2fac - !e2 = q3sq - e2c*ghel*a2fac - !e3 = e1 + e3c*ghel*a2fac**2 - !e4 = e1 - e4c*ghel*a2fac - !eden = e2*e4 + e3*e5c*gmel - !eden = MAX( eden, 1.0d-20 ) - !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden - !!JOE-Canuto/Kitamura mod - !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - !sm(k) = Prnum*sh(k) - !sm(k) = sm(k) * qdiv + elt = alp1*elt/vsc + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) - !Use level 2.0 functions as in original MYNN - sh(k) = sh(k) * qdiv - sm(k) = sm(k) * qdiv - !Or, use the simple Pr relationship - !sm(k) = Prnum*sh(k) + ! ** Strictly, el(i,k=1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) - !Recalculate terms for later use - !JOE-Canuto/Kitamura mod - !e1 = q3sq - e1c*ghel * qdiv**2 - !e2 = q3sq - e2c*ghel * qdiv**2 - !e3 = e1 + e3c*ghel * qdiv**2 - !e4 = e1 - e4c*ghel * qdiv**2 - e1 = q3sq - e1c*ghel*a2fac * qdiv**2 - e2 = q3sq - e2c*ghel*a2fac * qdiv**2 - e3 = e1 + e3c*ghel*a2fac**2 * qdiv**2 - e4 = e1 - e4c*ghel*a2fac * qdiv**2 - eden = e2*e4 + e3*e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) - !!JOE-Canuto/Kitamura mod - !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5 - !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - !sm(k) = Prnum*sh(k) - ELSE - !JOE-Canuto/Kitamura mod - !e1 = q3sq - e1c*ghel - !e2 = q3sq - e2c*ghel - !e3 = e1 + e3c*ghel - !e4 = e1 - e4c*ghel - e1 = q3sq - e1c*ghel*a2fac - e2 = q3sq - e2c*ghel*a2fac - e3 = e1 + e3c*ghel*a2fac**2 - e4 = e1 - e4c*ghel*a2fac - eden = e2*e4 + e3*e5c*gmel - eden = MAX( eden, 1.0d-20 ) + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels - qdiv = 1.0 - !Use level 2.5 stability functions - sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden - !!JOE-Canuto/Kitamura mod - !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - !sm(k) = Prnum*sh(k) - END IF !end Helfand & Labraga check + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + elb = alp2*qkw(k) / bv & + & *( 1.0 + alp3/alp2*& + &SQRT( vsc/( bv*elt ) ) ) + elf = alp2 * qkw(k)/bv - !Impose broad limits on Sh and Sm: - gmelq = MAX(gmel/q3sq, 1e-8) - sm25max = 10. !MIN(sm20*3.0, SQRT(.1936/gmelq)) - sh25max = 10. !MIN(sh20*3.0, 0.76*b2) - sm25min = 0.0 !MAX(sm20*0.1, 1e-6) - sh25min = 0.0 !MAX(sh20*0.1, 1e-6) + ELSE + elb = 1.0e10 + elf = elb + ENDIF - !JOE: Level 2.5 debug prints - ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 - IF ( debug_code ) THEN - IF ((sh(k)sh25max .OR. sm(k)>sm25max) ) THEN - print*,"In mym_turbulence 2.5: k=",k - print*," sm=",sm(k)," sh=",sh(k) - print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8) - print*," gm=",gm(k)," gh=",gh(k) - print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq - print*," qke=",qke(k)," el=",el(k) - print*," PBLH=",zi," u=",u(k)," v=",v(k) - print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden - print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),& - " SHdenom=",eden - ENDIF - ENDIF + z_m = MAX(0.,zwk - 4.) - !Enforce constraints for level 2.5 functions - IF ( sh(k) > sh25max ) sh(k) = sh25max - IF ( sh(k) < sh25min ) sh(k) = sh25min - !IF ( sm(k) > sm25max ) sm(k) = sm25max - !IF ( sm(k) < sm25min ) sm(k) = sm25min - !sm(k) = Prnum*sh(k) - sm(k) = MIN(sm(k), Prlimit*Sh(k)) + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF -! ** Level 3 : start ** - IF ( closure .GE. 3.0 ) THEN - t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 - r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 - c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) - t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) - r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) - c3sq = cov(k)*abk+cov(k-1)*afk + ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: + ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + ! el(k) = elb/( elb/elt+elb/els+1.0 ) -! Modified: Dec/22/2005, from here - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk - vqq = tv0 +vq(k)*abk +vq(k-1)*afk + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - t2sq = vtt*t2sq +vqq*c2sq - r2sq = vtt*c2sq +vqq*r2sq - c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) - t3sq = vtt*t3sq +vqq*c3sq - r3sq = vtt*c3sq +vqq*r3sq - c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) -! - cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) -! -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -! -! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** - ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) - ! to calculate an exact limit for c3sq: - auh = 27.*a1*((a2*a2fac)**2)*b2*(g/tref)**2 - aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(g/tref) - adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(g/tref)**2 - adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(g/tref) + el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* & - (12.*a1 + 3.*b2))*(g/tref) - aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + & - (18.*a1*c1 - b2)) + & - (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac)) + END DO - Req = -aeh/aem - Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) - !For now, use default values, since tests showed little/no sensitivity - Rsl = .12 !lower limit - Rsl2= 1.0 - 2.*Rsl !upper limit - !IF (k==2)print*,"Dynamic limit RSL=",Rsl - !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN - ! print*,'--- ERROR: MYNN: Dynamic Cw '// & - ! 'limit exceeds reasonable limits' - ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl - !ENDIF + CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH - !JOE-Canuto/Kitamura mod - !e2 = q3sq - e2c*ghel * qdiv**2 - !e3 = q3sq + e3c*ghel * qdiv**2 - !e4 = q3sq - e4c*ghel * qdiv**2 - e2 = q3sq - e2c*ghel*a2fac * qdiv**2 - e3 = q3sq + e3c*ghel*a2fac**2 * qdiv**2 - e4 = q3sq - e4c*ghel*a2fac * qdiv**2 - eden = e2*e4 + e3 *e5c*gmel * qdiv**2 + cns = 3.5 + alp1 = 0.21 + alp2 = 0.3 + alp3 = 1.5 + alp4 = 5.0 + alp5 = 0.2 + alp6 = 50. - !JOE-Canuto/Kitamura mod - !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) - wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - & *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 ) + ! Impose limits on the height integration for elt and the transition layer depth + zi2=MAX(zi,200.) !minzi) + h1=MAX(0.3*zi2,200.) + h1=MIN(h1,500.) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth - IF ( wden .NE. 0.0 ) THEN - !JOE: test dynamic limits - clow = q3sq*( 0.12-cw25 )*eden/wden - cupp = q3sq*( 0.76-cw25 )*eden/wden - !clow = q3sq*( Rsl -cw25 )*eden/wden - !cupp = q3sq*( Rsl2-cw25 )*eden/wden -! - IF ( wden .GT. 0.0 ) THEN - c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) - ELSE - c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) - END IF - END IF -! - e1 = e2 + e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) -! Modified: Dec/22/2005, up to here + qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels + thetaw(kts)=theta(kts) !theta at full-sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) - !JOE-Canuto/Kitamura mod - !e6c = 3.0*a2*cc3*gtr * dlsq/elsq - e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = 0.5*(qkw(k)**2) ! q -> TKE + thetaw(k)= theta(k)*abk + theta(k-1)*afk + END DO - !============================ - ! ** for Gamma_theta ** - !! enum = qdiv*e6c*( t3sq-t2sq ) - IF ( t2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ENDIF - gamt =-e1 *enum /eden + elt = 1.0e-5 + vsc = 1.0e-5 - !============================ - ! ** for Gamma_q ** - !! enum = qdiv*e6c*( r3sq-r2sq ) - IF ( r2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ENDIF - gamq =-e1 *enum /eden + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO - !============================ - ! ** for Sm' and Sh'd(Theta_V)/dz ** - !! enum = qdiv*e6c*( c3sq-c2sq ) - enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) + elt = MIN( MAX( alp1*elt/vsc, 10.), 400.) + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - !JOE-Canuto/Kitamura mod - !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 - smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + & - & e4c*a2fac)*a1/(a2*a2fac) + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) !full-sigma levels - gamv = e1 *enum*gtr/eden - sm(k) = sm(k) +smd + ! COMPUTE BouLac mixing length + CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) - !============================ - ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** - qdiv = 1.0 + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels - ! Level 3 debug prints - IF ( debug_code ) THEN - IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & - qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN - print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + !elb = alp2*qkw(k) / bv & ! formulation, + ! & *( 1.0 + alp3/alp2*& ! except keep + ! &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by zwk + elb = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) + elb = MIN(elb, zwk) + elf = 0.65 * qkw(k)/bv + !elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k)*edmf_w1(k)/bv) + ELSE + elb = 1.0e10 + elf = elb + ENDIF -! ** Level 3 : end ** + z_m = MAX(0.,zwk - 4.) - ELSE -! ** At Level 2.5, qdiv is not reset. ** - gamt = 0.0 - gamq = 0.0 - gamv = 0.0 - END IF -! -! Add min background stability function (diffusivity) within model levels -! with active plumes and low cloud fractions. - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF - ! for mass-flux columns - sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for clouds - sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) - ENDIF -! - elq = el(k)*qkw(k) - elh = elq*qdiv + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - ! Production of TKE (pdk), T-variance (pdt), - ! q-variance (pdq), and covariance (pdc) - pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) + & - & TKEprodTD(k) - pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) - pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) - pdc(k) = elh*( sh(k)*dtl(k)+gamt )& - &*dqw(k)*0.5 & - &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 + !add blending to use BouLac mixing length in free atmos; + !defined relative to the PBLH (zi) + transition layer (h1) + !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + !try squared-blending + !el_unstab = SQRT( els**2/(1. + (els1**2/elt**2) )) + el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb**2))) + el(k) = MIN (el(k), elf) + el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt - ! Contergradient terms - tcd(k) = elq*gamt - qcd(k) = elq*gamq + ! include scale-awareness, except for original MYNN + el(k) = el(k)*Psig_bl - ! Eddy Diffusivity/Viscosity divided by dz - dfm(k) = elq*sm(k) / dzk - dfh(k) = elq*sh(k) / dzk -! Modified: Dec/22/2005, from here -! ** In sub.mym_predict, dfq for the TKE and scalar variance ** -! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** - dfq(k) = dfm(k) -! Modified: Dec/22/2005, up to here + END DO - IF ( bl_mynn_tkebudget == 1) THEN - !TKE BUDGET -! dudz = ( u(k)-u(k-1) )/dzk -! dvdz = ( v(k)-v(k-1) )/dzk -! dTdz = ( thl(k)-thl(k-1) )/dzk + CASE (2) !Local (mostly) mixing length formulation -! upwp = -elq*sm(k)*dudz -! vpwp = -elq*sm(k)*dvdz -! Tpwp = -elq*sh(k)*dTdz -! Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) + Uonset = 3.5 + dz(kts)*0.1 + Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) + cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) + alp1 = 0.21 + alp2 = 0.30 + alp3 = 1.5 + alp4 = 5.0 + alp5 = alp2 !like alp2, but for free atmosphere + alp6 = 50.0 !used for MF mixing length - -!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + ! Impose limits on the height integration for elt and the transition layer depth + !zi2=MAX(zi,minzi) + zi2=MAX(zi, 200.) + !h1=MAX(0.3*zi2,mindz) + !h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h1=MAX(0.3*zi2,200.) + h1=MIN(h1,500.) + h2=h1*0.5 ! 1/4 transition layer depth - !!!Shear Term - !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) - qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered + qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-4)) - !!!Buoyancy Term - !!!qBUOY1D(k)=g*Tpwp/thl(k) - !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) - !qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) !! ORIGINAL CODE - - !! Buoyncy term takes the TKEprodTD(k) production now - qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE + END DO - !!!Dissipation Term (now it evaluated on mym_predict) - !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE - - !! >> EOB - ENDIF + elt = 1.0e-5 + vsc = 1.0e-5 - END DO -! + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + PBLH_PLUS_ENT = MAX(zi+h1, 100.) + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. PBLH_PLUS_ENT) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO - dfm(kts) = 0.0 - dfh(kts) = 0.0 - dfq(kts) = 0.0 - tcd(kts) = 0.0 - qcd(kts) = 0.0 + elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - tcd(kte) = 0.0 - qcd(kte) = 0.0 + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) -! - DO k = kts,kte-1 - dzk = dz(k) - tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) - qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) - END DO -! + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + dzk = 0.5*( dz(k)+dz(k-1) ) + cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + !impose min value on bv + bv = MAX( SQRT( gtr*dtv(k) ), 0.001) + !elb_mf = alp2*qkw(k) / bv & + elb_mf = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) + elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) + + !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.) + wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird + tau_cloud = MIN(MAX(ctau * wstar/grav, 30.), 150.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + tau_cloud = tau_cloud*(1.-wt) + 50.*wt + elf = MIN(MAX(tau_cloud*SQRT(MIN(qtke(k),40.)), & + & alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk) + + !IF (zwk > zi .AND. elf > 400.) THEN + ! ! COMPUTE BouLac mixing length + ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) + ! !elf = alp5*elBLavg0 + ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) + !ENDIF + + ELSE + ! use version in development for RAP/HRRR 2016 + ! JAYMES- + ! tau_cloud is an eddy turnover timescale; + ! see Teixeira and Cheinet (2004), Eq. 1, and + ! Cheinet and Teixeira (2003), Eq. 7. The + ! coefficient 0.5 is tuneable. Expression in + ! denominator is identical to vsc (a convective + ! velocity scale), except that elt is relpaced + ! by zi, and zero is replaced by 1.0e-4 to + ! prevent division by zero. + !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.) + wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird + tau_cloud = MIN(MAX(ctau * wstar/grav, 50.), 200.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + !tau_cloud = tau_cloud*(1.-wt) + 50.*wt + tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt + + elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk) + !elf = elb + elf = elb !/(1. + (elb/800.)) !bound free-atmos mixing length to < 800 m. + elb_mf = elb + END IF + elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m. +! elb_mf = elb_mf/(1. + (elb_mf/800.)) !bound buoyancy mixing length to < 800 m. + elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below + + z_m = MAX(0.,zwk - 4.) + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + ! "el_unstab" = blended els-elt + !el_unstab = els/(1. + (els1/elt)) + !try squared-blending + !el(k) = SQRT( els**2/(1. + (els1**2/elt**2) )) + el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb_mf**2))) + !el(k) = MIN(el_unstab, elb_mf) + el(k) = el(k)*(1.-wt) + elf*wt + + ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. + el_les= MIN(els/(1. + (els1/12.)), elb_mf) + el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les + + END DO + + END SELECT - if (spp_pbl==1) then - DO k = kts,kte - dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - END DO - endif -! RETURN #ifdef HARDCODE_VERTICAL # undef kts # undef kte #endif - END SUBROUTINE mym_turbulence + END SUBROUTINE mym_length ! ================================================================== -! SUBROUTINE mym_predict: -! -! Input variables: see subroutine mym_initialize and turbulence -! qke(nx,nz,ny) : qke at (n)th time level -! tsq, ...cov : ditto -! -! Output variables: -! qke(nx,nz,ny) : qke at (n+1)th time level -! tsq, ...cov : ditto -! -! Work arrays: -! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) -! bp (nx,nz,ny) : = 1/2*F, see below -! rp (nx,nz,ny) : = P-1/2*F*Q, see below -! -! # The equation for a turbulent quantity Q can be expressed as -! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) -! where A is the advection, D the diffusion, P the production, -! F*Q the dissipation and h and v denote horizontal and vertical, -! respectively. If Q is q^2, F is 2q/B_1L. -! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite -! difference equation is written as -! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) -! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) -! where n denotes the time level. -! When the advection and diffusion terms are discretized as -! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) -! Eq.(2) can be rewritten as -! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) -! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) -! where Q on the left-hand side is at (n+1)th time level. -! -! In this subroutine, a(k), b(k) and c(k) are obtained from -! subprogram coefvu and are passed to subprogram tinteg via -! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, -! respectively. Subprogram tinteg solves Eq.(4). +!>\ingroup gsd_mynn_edmf +!! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for +!! integration into the MYNN PBL scheme. WHILE loops were added to reduce the +!! computational expense. This subroutine computes the length scales up and down +!! and then computes the min, average of the up/down length scales, and also +!! considers the distance to the surface. +!\param dlu the distance a parcel can be lifted upwards give a finite +! amount of TKE. +!\param dld the distance a parcel can be displaced downwards given a +! finite amount of TKE. +!\param lb1 the minimum of the length up and length down +!\param lb2 the average of the length up and length down + SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) ! -! Modify this subroutine according to your numerical integration -! scheme (program). +! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW +! and modified for integration into the MYNN PBL scheme. +! WHILE loops were added to reduce the computational expense. +! This subroutine computes the length scales up and down +! and then computes the min, average of the up/down +! length scales, and also considers the distance to the +! surface. ! +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down !------------------------------------------------------------------- -!>\ingroup gsd_mynn_edmf -!! This subroutine predicts the turbulent quantities at the next step. - SUBROUTINE mym_predict (kts,kte, & - & closure, & - & delt, & - & dz, & - & ust, flt, flq, pmz, phh, & - & el, dfq, rho, & - & pdk, pdt, pdq, pdc, & - & qke, tsq, qsq, cov, & - & s_aw,s_awqke,bl_mynn_edmf_tke, & - & qWT1D, qDISS1D,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) - -!------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - REAL, INTENT(IN) :: closure - INTEGER, INTENT(IN) :: bl_mynn_edmf_tke - REAL, INTENT(IN) :: delt - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, ust, pmz, phh - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov -! WA 8/3/15 - REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw - - !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D - INTEGER, INTENT(IN) :: bl_mynn_tkebudget - REAL, DIMENSION(kts:kte) :: tke_up,dzinv - !! >> EOB - - INTEGER :: k - REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q - REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz + INTEGER, INTENT(IN) :: k,kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + REAL, INTENT(OUT) :: lb1,lb2 + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) - IF (bl_mynn_edmf_tke == 0) THEN - onoff=0.0 - ELSE - onoff=1.0 - ENDIF + !LOCAL VARS + INTEGER :: izz, found + REAL :: dlu,dld + REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz -! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = vk*0.5*dz(kts) -! -! ** dfq for the TKE is 3.0*dfm. ** -! - DO k = kts,kte -!! qke(k) = MAX(qke(k), 0.0) - qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) - df3q(k)=Sqfac*dfq(k) - dtz(k)=delt/dz(k) - END DO -! -!JOE-add conservation + stability criteria - !Prepare "constants" for diffusion equation. - !khdz = rho*Kh/dz = rho*dfh - rhoz(kts) =rho(kts) - rhoinv(kts)=1./rho(kts) - kqdz(kts) =rhoz(kts)*df3q(kts) - kmdz(kts) =rhoz(kts)*dfq(kts) - DO k=kts+1,kte - rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) - rhoz(k) = MAX(rhoz(k),1E-4) - rhoinv(k)=1./MAX(rho(k),1E-4) - kqdz(k) = rhoz(k)*df3q(k) ! for TKE - kmdz(k) = rhoz(k)*dfq(k) ! for T'2, q'2, and T'q' - ENDDO - rhoz(kte+1)=rhoz(kte) - kqdz(kte+1)=rhoz(kte+1)*df3q(kte) - kmdz(kte+1)=rhoz(kte+1)*dfq(kte) - !stability criteria for mf - DO k=kts+1,kte-1 - kqdz(k) = MAX(kqdz(k), 0.5* s_aw(k)) - kqdz(k) = MAX(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) - kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - ENDDO -!JOE-end conservation mods + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu=zw(kte+1)-zw(k)-dz(k)*0.5 + zzz=0. + zup_inf=0. + beta=gtr !Buoyancy coefficient (g/tref) - pdk1 = 2.0*ust**3*pmz/( vkz ) - phm = 2.0/ust *phh/( vkz ) - pdt1 = phm*flt**2 - pdq1 = phm*flq**2 - pdc1 = phm*flt*flq -! -! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. ** - pdk(kts) = pdk1 -pdk(kts+1) + !print*,"FINDING Dup, k=",k," zw=",zw(k) -!! pdt(kts) = pdt1 -pdt(kts+1) -!! pdq(kts) = pdq1 -pdq(kts+1) -!! pdc(kts) = pdc1 -pdc(kts+1) - pdt(kts) = pdt(kts+1) - pdq(kts) = pdq(kts+1) - pdc(kts) = pdc(kts+1) -! -! ** Prediction of twice the turbulent kinetic energy ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b1l = b1*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b1l - rp(k) = pdk(k+1) + pdk(k) - END DO + if (k .lt. kte) then !cant integrate upwards from highest level + found = 0 + izz=k + DO WHILE (found .EQ. 0) -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k + !print*," ",k,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer k to izz+1 + !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(k)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & + & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(k))then + tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dlu=zzz-dzt+tl + !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF -! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. - DO k=kts,kte-1 -! a(k-kts+1)=-dtz(k)*df3q(k) -! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt -! c(k-kts+1)=-dtz(k)*df3q(k+1) -! d(k-kts+1)=rp(k)*delt + qke(k) -! WA 8/3/15 add EDMF contribution -! a(k)= - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff -! b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & -! + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt -! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff -!JOE 8/22/20 improve conservation - a(k)= - dtz(k)*kqdz(k)*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff - b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) & - & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & - & + bp(k)*delt - c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - d(k)=rp(k)*delt + qke(k) & - & + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff - ENDDO + ENDDO -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*df3q(k) -!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) -!! c(k-kts+1)=-dtz(k)*df3q(k+1) -!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt -!! ENDDO + endif -!! "no flux at top" -! a(kte)=-1. !0. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. -!! "prescribed value" - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qke(kte) + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld=zw(k) + zzz=0. -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) + !print*,"FINDING Ddown, k=",k," zwk=",zw(k) + if (k .gt. kts) then !cant integrate downwards from lowest level - DO k=kts,kte -! qke(k)=max(d(k-kts+1), 1.e-4) - qke(k)=max(x(k), 1.e-4) - qke(k)=min(qke(k), 150.) - ENDDO - - -!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - IF (bl_mynn_tkebudget == 1) THEN - !! TKE Vertical transport << EOBvt - tke_up=0.5*qke - dzinv=1./dz - k=kts - qWT1D(k)=dzinv(k)*( & - & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) & - & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & - & + (s_aw(k+1)-s_aw(k))*tke_up(k) & - & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered - DO k=kts+1,kte-1 - qWT1D(k)=dzinv(k)*( & - & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) & - & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & - & + (s_aw(k+1)-s_aw(k))*tke_up(k) & - & - s_aw(k)*tke_up(k-1) & - & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(k)*dzt + !print*," ",k,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(k))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & + & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(k)) then + tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dld=zzz-dzt+tl + !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF ENDDO - k=kte - qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & - & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared - !! >> EOBvt - qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered - END IF -!! >> EOB - - IF ( closure > 2.5 ) THEN - ! ** Prediction of the moisture variance ** - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdq(k+1) +pdq(k) - END DO + endif - !zero gradient for qsq at bottom and top - !a(1)=0. - !b(1)=1. - !c(1)=-1. - !d(1)=0. + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos + lb1 = min(dlu,dld) !minimum + !JOE-fight floating point errors + dlu=MAX(0.1,MIN(dlu,1000.)) + dld=MAX(0.1,MIN(dld,1000.)) + lb2 = sqrt(dlu*dld) !average - biased towards smallest + !lb2 = 0.5*(dlu+dld) !average - ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k)= - dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt - c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) - d(k)=rp(k)*delt + qsq(k) - ENDDO + if (k .eq. kte) then + lb1 = 0. + lb2 = 0. + endif + !print*,"IN MYNN-BouLac",k,lb1 + !print*,"IN MYNN-BouLac",k,dld,dlu - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. + END SUBROUTINE boulac_length0 -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte - !qsq(k)=d(k-kts+1) - qsq(k)=MAX(x(k),1e-12) - ENDDO - ELSE - !level 2.5 - use level 2 diagnostic - DO k = kts,kte-1 - IF ( qkw(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) - END IF - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - END DO - qsq(kte)=qsq(kte-1) - END IF -!!!!!!!!!!!!!!!!!!!!!!end level 2.6 +! ================================================================== +!>\ingroup gsd_mynn_edmf +!! This subroutine was taken from the BouLac scheme in WRF-ARW +!! and modified for integration into the MYNN PBL scheme. +!! WHILE loops were added to reduce the computational expense. +!! This subroutine computes the length scales up and down +!! and then computes the min, average of the up/down +!! length scales, and also considers the distance to the +!! surface. + SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- - IF ( closure .GE. 3.0 ) THEN -! -! ** dfq for the scalar variance is 1.0*dfm. ** -! -! ** Prediction of the temperature variance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdt(k+1) + pdt(k) - END DO - -!zero gradient for tsq at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. + INTEGER, INTENT(IN) :: kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - !a(k-kts+1)=-dtz(k)*dfq(k) - !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - !c(k-kts+1)=-dtz(k)*dfq(k+1) - !d(k-kts+1)=rp(k)*delt + tsq(k) -!JOE 8/22/20 improve conservation - a(k)= - dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt - c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) - d(k)=rp(k)*delt + tsq(k) - ENDDO + !LOCAL VARS + INTEGER :: iz, izz, found + REAL, DIMENSION(kts:kte) :: dlu,dld + REAL, PARAMETER :: Lmax=2000. !soft limit + REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt -!! ENDDO + !print*,"IN MYNN-BouLac",kts, kte - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) + do iz=kts,kte - DO k=kts,kte -! tsq(k)=d(k-kts+1) - tsq(k)=x(k) - ENDDO + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)*0.5 + zzz=0. + zup_inf=0. + beta=gtr !Buoyancy coefficient (g/tref) -! ** Prediction of the temperature-moisture covariance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdc(k+1) + pdc(k) - END DO - -!zero gradient for tqcov at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. + !print*,"FINDING Dup, k=",iz," zw=",zw(iz) -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - !a(k-kts+1)=-dtz(k)*dfq(k) - !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - !c(k-kts+1)=-dtz(k)*dfq(k+1) - !d(k-kts+1)=rp(k)*delt + cov(k) -!JOE 8/22/20 improve conservation - a(k)= - dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt - c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) - d(k)=rp(k)*delt + cov(k) - ENDDO + if (iz .lt. kte) then !cant integrate upwards from highest level -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt -!! ENDDO + found = 0 + izz=iz + DO WHILE (found .EQ. 0) - a(kte)=-1. !0. - b(kte)=1. - c(kte)=0. - d(kte)=0. + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz + !print*," ",iz,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer iz to izz+1 + !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(iz)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & + & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(iz))then + tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dlu(iz)=zzz-dzt+tl + !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! cov(k)=d(k-kts+1) - cov(k)=x(k) - ENDDO - - ELSE + ENDDO - !Not level 3 - default to level 2 diagnostic - DO k = kts,kte-1 - IF ( qkw(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) - END IF -! - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - - tsq(kte)=tsq(kte-1) - cov(kte)=cov(kte-1) - - END IF + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld(iz)=zw(iz) + zzz=0. -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif + !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) + if (iz .gt. kts) then !cant integrate downwards from lowest level - END SUBROUTINE mym_predict - + found = 0 + izz=iz + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(iz)*dzt + !print*," ",iz,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(iz))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & + & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(iz)) then + tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dld(iz)=zzz-dzt+tl + !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos + lb1(iz) = min(dlu(iz),dld(iz)) !minimum + !JOE-fight floating point errors + dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) + dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) + lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest + !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average + + !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). + lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) + lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) + + if (iz .eq. kte) then + lb1(kte) = lb1(kte-1) + lb2(kte) = lb2(kte-1) + endif + !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) + !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) + + ENDDO + + END SUBROUTINE boulac_length +! ! ================================================================== -! SUBROUTINE mym_condensation: +! SUBROUTINE mym_turbulence: ! -! Input variables: see subroutine mym_initialize and turbulence -! exner(nz) : Perturbation of the Exner function (J/kg K) -! defined on the walls of the grid boxes -! This is usually computed by integrating -! d(pi)/dz = h*g*tv/tref**2 -! from the upper boundary, where tv is the -! virtual potential temperature minus tref. +! Input variables: see subroutine mym_initialize +! closure : closure level (2.5, 2.6, or 3.0) +! +! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. ! ! Output variables: see subroutine mym_initialize -! cld(nx,nz,ny) : Cloud fraction +! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, +! divided by dz (not dz*h(i,j)) (m/s) +! dfh(nx,nz,ny) : Diffusivity coefficient for heat, +! divided by dz (not dz*h(i,j)) (m/s) +! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, +! divided by dz (not dz*h(i,j)) (m/s) +! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l +! (K/s) +! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w +! (kg/kg s) +! pd?(nx,nz,ny) : Half of the production terms ! -! Work arrays: -! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation -! specific humidity at T=Tl -! alp(nx,nz,ny) : Functions in the condensation process -! bet(nx,nz,ny) : ditto -! sgm(nx,nz,ny) : Combined standard deviation sigma_s -! multiplied by 2/alp +! Only tcd and qcd are defined at the center of the grid boxes ! -! # qmq, alp, bet and sgm are allowed to share storage units with -! any four of other work arrays for saving memory. +! # DO NOT forget that tcd and qcd are added on the right-hand side +! of the equations for Theta_l and Q_w, respectively. ! -! # Results are sensitive particularly to values of cp and rd. -! Set these values to those adopted by you. +! Work arrays: see subroutine mym_initialize and level2 ! -!------------------------------------------------------------------- -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the nonconvective component of the -!! subgrid cloud fraction and mixing ratio as well as the functions used to -!! calculate the buoyancy flux. Different cloud PDFs can be selected by -!! use of the namelist parameter \p bl_mynn_cloudpdf . - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, zw, & - & thl, qw, qv, qc, qi, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& - & qc_bl1D, qi_bl1D, & - & cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm, rmo, & - & spp_pbl,rstoch_col ) +! # dtl, dqw, dtv, gm and gh are allowed to share storage units with +! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. +! +!>\ingroup gsd_mynn_edmf +!! This subroutine calculates the vertical diffusivity coefficients and the +!! production terms for the turbulent quantities. +!>\section gen_mym_turbulence GSD mym_turbulence General Algorithm +!! Two subroutines mym_level2() and mym_length() are called within this +!!subrouine to collect variable to carry out successive calculations: +!! - mym_level2() calculates the level 2 nondimensional wind shear \f$G_M\f$ +!! and vertical temperature gradient \f$G_H\f$ as well as the level 2 stability +!! functions \f$S_h\f$ and \f$S_m\f$. +!! - mym_length() calculates the mixing lengths. +!! - The stability criteria from Helfand and Labraga (1989) are applied. +!! - The stability functions for level 2.5 or level 3.0 are calculated. +!! - If level 3.0 is used, counter-gradient terms are calculated. +!! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$ +!! are calculated. +!! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated. +!! - TKE budget terms are calculated (if the namelist parameter \p bl_mynn_tkebudget +!! is set to True) + SUBROUTINE mym_turbulence ( & + & kts,kte, & + & closure, & + & dz, dx, zw, & + & u, v, thl, thetav, ql, qw, & + & thlsg, qwsg, & + & qke, tsq, qsq, cov, & + & vt, vq, & + & rmo, flt, flq, & + & zi,theta, & + & sh, sm, & + & El, & + & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & + & bl_mynn_tkebudget, & + & Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & TKEprodTD, & + & spp_pbl,rstoch_col) !------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf +! + INTEGER, INTENT(IN) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, & - &tsq, qsq, cov, th + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf + REAL, INTENT(IN) :: closure + REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& + &TKEprodTD,thlsg,qwsg - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& + &pdk,pdt,pdq,pdc,tcd,qcd,el - REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,RH - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & - cldfra_bl1D - DOUBLE PRECISION :: t3sq, r3sq, c3sq + REAL, DIMENSION(kts:kte), INTENT(inout) :: & + qWT1D,qSHEAR1D,qBUOY1D,qDISS1D + REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new + REAL :: dudz,dvdz,dTdz,& + upwp,vpwp,Tpwp + LOGICAL, INTENT(in) :: bl_mynn_tkebudget - REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,qlk,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,& - &ls_min,ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& - &low_weight - INTEGER :: i,j,k + REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh - REAL :: erf + INTEGER :: k +! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c + REAL :: e6c,dzk,afk,abk,vtt,vqq,& + &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - !VARIABLES FOR ALTERNATIVE SIGMA - REAL::dth,dtl,dqw,dzk,els - REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el + REAL :: zi, cldavg + REAL, DIMENSION(kts:kte), INTENT(in) :: theta - !variables for SGS BL clouds - REAL :: zagl,damp,PBLH2 - REAL :: lfac - INTEGER, PARAMETER :: sig_order = 2 !sigma form, 1: use state variables, 2: higher-order variables + REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod - !JAYMES: variables for tropopause-height estimation - REAL :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo + REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& + gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,& + sm_pbl,sh_pbl,zi2,wt + + DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel + DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv + DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden ! Stochastic INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: qw_pert + REAL :: Prnum + REAL, PARAMETER :: Prlimit = 5.0 -! First, obtain an estimate for the tropopause height (k), using the method employed in the -! Thompson subgrid-cloud scheme. This height will be a consideration later when determining -! the "final" subgrid-cloud properties. -! JAYMES: added 3 Nov 2016, adapted from G. Thompson - DO k = kte-3, kts, -1 - theta1 = th(k) - theta2 = th(k+2) - ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) - ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) - if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & - & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then - goto 86 - endif - ENDDO - 86 continue - k_tropo = MAX(kts+2, k+2) +! +! tv0 = 0.61*tref +! gtr = 9.81/tref +! +! cc2 = 1.0-c2 +! cc3 = 1.0-c3 +! e1c = 3.0*a2*b2*cc3 +! e2c = 9.0*a1*a2*cc2 +! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) +! e4c = 12.0*a1*a2*cc2 +! e5c = 6.0*a1*a1 +! - zagl = 0. + CALL mym_level2 (kts,kte, & + & dz, & + & u, v, thl, thetav, qw, & + & thlsg, qwsg, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! + CALL mym_length ( & + & kts,kte, & + & dz, dx, zw, & + & rmo, flt, flq, & + & vt, vq, & + & u, v, qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & + & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf ) +! - SELECT CASE(bl_mynn_cloudpdf) + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + elsq = el (k)**2 + q3sq = qkw(k)**2 + q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) - CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + sh20 = MAX(sh(k), 1e-5) + sm20 = MAX(sm(k), 1e-5) + sh(k)= MAX(sh(k), 1e-5) - DO k = kts,kte-1 - t = th(k)*exner(k) + !Canuto/Kitamura mod + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + ! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) + IF (CKmod .eq. 1) THEN + a2fac = 1./(1. + MAX(ri,0.0)) + ELSE + a2fac = 1. + ENDIF + !end Canuto/Kitamura mod -!x if ( ct .gt. 0.0 ) then -! a = 17.27 -! b = 237.3 -!x else -!x a = 21.87 -!x b = 265.5 -!x end if + !level 2.0 Prandtl number + !Prnum = MIN(sm20/sh20, 4.0) + !The form of Zilitinkevich et al. (2006) but modified + !half-way towards Esau and Grachev (2007, Wind Eng) + !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit) + Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit) + !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit) ! -! ** 3.8 = 0.622*6.11 (hPa) ** - - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - !Sommeria and Deardorff (1977) scheme, as implemented - !in Nakanishi and Niino (2009), Appendix B - t3sq = MAX( tsq(k), 0.0 ) - r3sq = MAX( qsq(k), 0.0 ) - c3sq = cov(k) - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) - r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq - !DEFICIT/EXCESS WATER CONTENT - qmq(k) = qw(k) -qsl - !ORIGINAL STANDARD DEVIATION - sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) - !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq(k) / sgm(k) - !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 - cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) +! Modified: Dec/22/2005, from here, (dlsq -> elsq) + gmel = gm (k)*elsq + ghel = gh (k)*elsq +! Modified: Dec/22/2005, up to here - q1k = q1(k) - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql(k) = alp(k)*sgm(k)*qll - !LIMIT SPECIES TO TEMPERATURE RANGES - liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) - qc_bl1D(k) = liq_frac*ql(k) - qi_bl1D(k) = (1.0 - liq_frac)*ql(k) + ! Level 2.0 debug prints + IF ( debug_code ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN + print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 +! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** - !Now estimate the buoyancy flux functions - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp +!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +!JOE-end - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) - rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac + IF ( q3sq .LT. q2sq ) THEN + !Apply Helfand & Labraga mod + qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) +! + !Use level 2.5 stability functions + !e1 = q3sq - e1c*ghel*a2fac + !e2 = q3sq - e2c*ghel*a2fac + !e3 = e1 + e3c*ghel*a2fac**2 + !e4 = e1 - e4c*ghel*a2fac + !eden = e2*e4 + e3*e5c*gmel + !eden = MAX( eden, 1.0d-20 ) + !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + !sm(k) = Prnum*sh(k) + !sm(k) = sm(k) * qdiv - END DO + !Use level 2.0 functions as in original MYNN + sh(k) = sh(k) * qdiv + sm(k) = sm(k) * qdiv + ! !sm_pbl = sm(k) * qdiv + ! + ! !Or, use the simple Pr relationship + ! sm(k) = Prnum*sh(k) + ! + ! !or blend them: + ! zi2 = MAX(zi, 300.) + ! wt =.5*TANH((zw(k) - zi2)/200.) + .5 + ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt - CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and - !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) + !Recalculate terms for later use + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel * qdiv**2 + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = e1 + e3c*ghel * qdiv**2 + !e4 = e1 - e4c*ghel * qdiv**2 + e1 = q3sq - e1c*ghel*a2fac * qdiv**2 + e2 = q3sq - e2c*ghel*a2fac * qdiv**2 + e3 = e1 + e3c*ghel*a2fac**2 * qdiv**2 + e4 = e1 - e4c*ghel*a2fac * qdiv**2 + eden = e2*e4 + e3*e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5 + !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + !sm(k) = Prnum*sh(k) + ELSE + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel + !e2 = q3sq - e2c*ghel + !e3 = e1 + e3c*ghel + !e4 = e1 - e4c*ghel + e1 = q3sq - e1c*ghel*a2fac + e2 = q3sq - e2c*ghel*a2fac + e3 = e1 + e3c*ghel*a2fac**2 + e4 = e1 - e4c*ghel*a2fac + eden = e2*e4 + e3*e5c*gmel + eden = MAX( eden, 1.0d-20 ) - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) + qdiv = 1.0 + !Use level 2.5 stability functions + sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + ! sm_pbl = q3sq*a1*( e3-3.0*c1*e4 )/eden + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + ! sm(k) = Prnum*sh(k) - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if - dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & - b2 * MAX(Sh(k),0.03))/4. * & - (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - qmq(k) = qw(k) -qsl - q1(k) = qmq(k) / sgm(k) - cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + ! !or blend them: + ! zi2 = MAX(zi, 300.) + ! wt = .5*TANH((zw(k) - zi2)/200.) + .5 + ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt + END IF !end Helfand & Labraga check - !now compute estimated lwc for PBL scheme's use - !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and - !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 - q1k = q1(k) - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cldfra_bl1D(K)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll - liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) - qc_bl1D(k) = liq_frac*ql(k) - qi_bl1D(k) = (1.0 - liq_frac)*ql(k) + !Impose broad limits on Sh and Sm: + gmelq = MAX(gmel/q3sq, 1e-8) + sm25max = 4. !MIN(sm20*3.0, SQRT(.1936/gmelq)) + sh25max = 4. !MIN(sh20*3.0, 0.76*b2) + sm25min = 0.0 !MAX(sm20*0.1, 1e-6) + sh25min = 0.0 !MAX(sh20*0.1, 1e-6) - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 + !JOE: Level 2.5 debug prints + ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 + IF ( debug_code ) THEN + IF ((sh(k)sh25max .OR. sm(k)>sm25max) ) THEN + print*,"In mym_turbulence 2.5: k=",k + print*," sm=",sm(k)," sh=",sh(k) + print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8) + print*," gm=",gm(k)," gh=",gh(k) + print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq + print*," qke=",qke(k)," el=",el(k) + print*," PBLH=",zi," u=",u(k)," v=",v(k) + print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden + print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),& + " SHdenom=",eden + ENDIF + ENDIF - !Now estimate the buoyancy flux functions - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp + !Enforce constraints for level 2.5 functions + IF ( sh(k) > sh25max ) sh(k) = sh25max + IF ( sh(k) < sh25min ) sh(k) = sh25min + !IF ( sm(k) > sm25max ) sm(k) = sm25max + !IF ( sm(k) < sm25min ) sm(k) = sm25min + !sm(k) = Prnum*sh(k) + sm(k) = MIN(sm(k), Prlimit*Sh(k)) - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) - rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) +! ** Level 3 : start ** + IF ( closure .GE. 3.0 ) THEN + t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 + r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 + c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) + t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) + r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) + c3sq = cov(k)*abk+cov(k-1)*afk - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac +! Modified: Dec/22/2005, from here + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk + vqq = tv0 +vq(k)*abk +vq(k-1)*afk - END DO + t2sq = vtt*t2sq +vqq*c2sq + r2sq = vtt*c2sq +vqq*r2sq + c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) + t3sq = vtt*t3sq +vqq*c3sq + r3sq = vtt*c3sq +vqq*r3sq + c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) +! + cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) +! +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +! +! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** + ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) + ! to calculate an exact limit for c3sq: + auh = 27.*a1*((a2*a2fac)**2)*b2*(gtr)**2 + aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(gtr) + adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(gtr)**2 + adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(gtr) - CASE (2, -2) + aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* & + (12.*a1 + 3.*b2))*(gtr) + aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + & + (18.*a1*c1 - b2)) + & + (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac)) - if (sig_order == 1) then - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !using the first-order version of sigma (their eq. 5). - !JAYMES- this added 27 Apr 2015 - PBLH2=MAX(10.,PBLH1) - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + Req = -aeh/aem + Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) + !For now, use default values, since tests showed little/no sensitivity + Rsl = .12 !lower limit + Rsl2= 1.0 - 2.*Rsl !upper limit + !IF (k==2)print*,"Dynamic limit RSL=",Rsl + !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN + ! print*,'--- ERROR: MYNN: Dynamic Cw '// & + ! 'limit exceeds reasonable limits' + ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl + !ENDIF - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) + !JOE-Canuto/Kitamura mod + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = q3sq + e3c*ghel * qdiv**2 + !e4 = q3sq - e4c*ghel * qdiv**2 + e2 = q3sq - e2c*ghel*a2fac * qdiv**2 + e3 = q3sq + e3c*ghel*a2fac**2 * qdiv**2 + e4 = q3sq - e4c*ghel*a2fac * qdiv**2 + eden = e2*e4 + e3 *e5c*gmel * qdiv**2 - xl = xl_blend(t) ! obtain latent heat - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; - ! the numerator of Q1 - qmq(k) = a(k) * (qw_pert - qsat_tl) - b(k) = a(k)*rsl ! CB02 variable "b" - - dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & - & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + !JOE-Canuto/Kitamura mod + !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) + wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + & *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 ) - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if + IF ( wden .NE. 0.0 ) THEN + !JOE: test dynamic limits + clow = q3sq*( 0.12-cw25 )*eden/wden + cupp = q3sq*( 0.76-cw25 )*eden/wden + !clow = q3sq*( Rsl -cw25 )*eden/wden + !cupp = q3sq*( Rsl2-cw25 )*eden/wden +! + IF ( wden .GT. 0.0 ) THEN + c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) + ELSE + c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) + END IF + END IF +! + e1 = e2 + e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) +! Modified: Dec/22/2005, up to here - cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 - ! in CB02 - zagl = zagl + dz(k) - !Use analog to surface layer length scale to make the cloud mixing length scale - !become less than z in stable conditions. - els = zagl !save for more testing: /(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) + !JOE-Canuto/Kitamura mod + !e6c = 3.0*a2*cc3*gtr * dlsq/elsq + e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq - !ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) - ls_min = 300. + MIN(2.*MAX(HFX1,0.),150.) - ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: - if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) - ! 25 m < ls_min(=zagl) < 300 m - lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: - ! lfac(750 m) = 4.4 - ! lfac(3 km) = 5.0 - ! lfac(13 km) = 6.0 - ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m - ! Note: CB02 use 900 m as a constant free-atmosphere length scale. + !============================ + ! ** for Gamma_theta ** + !! enum = qdiv*e6c*( t3sq-t2sq ) + IF ( t2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ENDIF + gamt =-e1 *enum /eden - ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the - ! MYNN master length scale (el) must exceed 60 m before ls - ! becomes responsive to el, otherwise ls = ls_min = 300 m. + !============================ + ! ** for Gamma_q ** + !! enum = qdiv*e6c*( r3sq-r2sq ) + IF ( r2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ENDIF + gamq =-e1 *enum /eden - sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: - & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, - & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, - & +b(k)**2 * cdhdz**2))) ! < 3rd term - ! CB02 use a multiplier of 0.2, but 0.225 is chosen - ! based on tests + !============================ + ! ** for Sm' and Sh'd(Theta_V)/dz ** + !! enum = qdiv*e6c*( c3sq-c2sq ) + enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - END DO + !JOE-Canuto/Kitamura mod + !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 + smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + & + & e4c*a2fac)*a1/(a2*a2fac) - else + gamv = e1 *enum*gtr/eden + sm(k) = sm(k) +smd - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !but with use of higher-order moments to estimate sigma - PBLH2=MAX(10.,PBLH1) - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + !============================ + ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** + qdiv = 1.0 - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) + ! Level 3 debug prints + IF ( debug_code ) THEN + IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & + qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN + print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF - xl = xl_blend(t) ! obtain latent heat - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b(k) = a(k)*rsl ! CB02 variable "b" +! ** Level 3 : end ** - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + ELSE +! ** At Level 2.5, qdiv is not reset. ** + gamt = 0.0 + gamq = 0.0 + gamv = 0.0 + END IF +! +! Add min background stability function (diffusivity) within model levels +! with active plumes and low cloud fractions. + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !This form of qmq (the numerator of Q1) no longer uses the a(k) factor - qmq(k) = qw_pert - qsat_tl ! saturation deficit/excess; + ! for mass-flux columns + sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + ! for clouds + sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) + sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) + ENDIF +! + elq = el(k)*qkw(k) + elh = elq*qdiv - !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) - !except neglect all but the first term for sig_r - r3sq = MAX( qsq(k), 0.0 ) - !Calculate sigma using higher-order moments: - sgm(k) = SQRT( r3sq ) - !Set limits on sigma relative to saturation water vapor - sgm(k) = MIN( sgm(k), qsat_tl*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tl*0.050 ) !Note: 0.02 results in SWDOWN similar - !to the first-order version of sigma - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + ! Production of TKE (pdk), T-variance (pdt), + ! q-variance (pdq), and covariance (pdc) + pdk(k) = elq*( sm(k)*gm(k) & + & +sh(k)*gh(k)+gamv ) + & + & TKEprodTD(k) + pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) + pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) + pdc(k) = elh*( sh(k)*dtl(k)+gamt )& + &*dqw(k)*0.5 & + &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 - !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - !This form only allows cloud fractions out to q1 = -1.8 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) - !This form only allows cloud fractions out to q1 = -1 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) + ! Contergradient terms + tcd(k) = elq*gamt + qcd(k) = elq*gamq - END DO + ! Eddy Diffusivity/Viscosity divided by dz + dfm(k) = elq*sm(k) / dzk + dfh(k) = elq*sh(k) / dzk +! Modified: Dec/22/2005, from here +! ** In sub.mym_predict, dfq for the TKE and scalar variance ** +! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** + dfq(k) = dfm(k) +! Modified: Dec/22/2005, up to here - endif !end sig_order option + IF ( bl_mynn_tkebudget ) THEN + !TKE BUDGET +! dudz = ( u(k)-u(k-1) )/dzk +! dvdz = ( v(k)-v(k-1) )/dzk +! dTdz = ( thl(k)-thl(k-1) )/dzk - ! Specify hydrometeors - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - ! "fng" represents the non-Gaussian contribution to the liquid - ! water flux; these formulations are from Cuijpers and Bechtold - ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, - ! hereafter BCMT95 - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) +! upwp = -elq*sm(k)*dudz +! vpwp = -elq*sm(k)*dvdz +! Tpwp = -elq*sh(k)*dTdz +! Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) - !CLOUD WATER AND ICE - IF (q1k < 0.) THEN !unsaturated - ql_water = sgm(k)*EXP(1.2*q1k-1) - ql_ice = sgm(k)*EXP(1.2*q1k-1.) - !Reduce ice mixing ratios in the upper troposphere -! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 -! ql_ice = low_weight * sgm(k)*EXP(1.1*q1k-1.6) & !low-lev -! + (1.-low_weight) * sgm(k)*EXP(1.1*q1k-2.8)!upper-lev - ELSE IF (q1k > 2.) THEN !supersaturated - ql_water = sgm(k)*q1k - ql_ice = sgm(k)*q1k - !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*q1k - ELSE !slightly saturated (0 > q1 < 2) - ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ENDIF + +!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - !In saturated grid cells, use average of current estimate and prev time step - IF ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) - IF ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) + !!!Shear Term + !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) + qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered - IF (cldfra_bl1D(k) < 0.01) THEN - ql_ice = 0.0 - ql_water = 0.0 - cldfra_bl1D(k) = 0.0 - ENDIF + !!!Buoyancy Term + !!!qBUOY1D(k)=grav*Tpwp/thl(k) + !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) + !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE + + !! Buoyncy term takes the TKEprodTD(k) production now + qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered - !PHASE PARTITIONING: Make some inferences about the relative amounts of - !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, - !use a simple temperature-dependent partitioning. - IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning - IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid - liq_frac = 1.0 - ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice - liq_frac = 0.0 - ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably - ! large amounts; assume subgrid follows - ! same partioning - liq_frac = qc(k) / ( qc(k) + qi(k) ) - ELSE - liq_frac = MIN(1.0, MAX(0.0, (t-238.)/31.)) ! explicit contains mixed phase, but at least one - ! species is very small, so make a temperature- - ! depedent guess - ENDIF - ELSE ! no explicit condensate, so make a temperature-dependent guess - liq_frac = MIN(1.0, MAX(0.0, (t-238.)/31.)) - ENDIF + !!!Dissipation Term (now it evaluated on mym_predict) + !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE + + !! >> EOB + ENDIF - qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice - qi_bl1D(k) = (1.0-liq_frac)*ql_ice + END DO +! - !Above tropopause: eliminate subgrid clouds from CB scheme - if (k .ge. k_tropo-1) then - cldfra_bl1D(K) = 0. - qc_bl1D(k) = 0. - qi_bl1D(k) = 0. - endif - ENDDO + dfm(kts) = 0.0 + dfh(kts) = 0.0 + dfq(kts) = 0.0 + tcd(kts) = 0.0 + qcd(kts) = 0.0 - !Buoyancy-flux-related calculations follow... - DO k = kts,kte-1 - t = th(k)*exner(k) + tcd(kte) = 0.0 + qcd(kte) = 0.0 - ! "Fng" represents the non-Gaussian transport factor - ! (non-dimensional) from Bechtold et al. 1995 - ! (hereafter BCMT95), section 3(c). Their suggested - ! forms for Fng (from their Eq. 20) are: - !IF (q1k < -2.) THEN - ! Fng = 2.-q1k - !ELSE IF (q1k > 0.) THEN - ! Fng = 1. - !ELSE - ! Fng = 1.-1.5*q1k - !ENDIF - !limiting to avoid mixing away stratus, was -5 - q1k=MAX(Q1(k),-1.0) - IF (q1k .GE. 1.0) THEN - Fng = 1.0 - ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN - Fng = EXP(-0.4*(q1k-1.0)) - ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(q1k+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) - ENDIF - Fng = MIN(Fng, 20.) - - xl = xl_blend(t) - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor - ! of T/theta. Strictly, b(k) above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - MIN(cldfra_bl1D(K),0.5)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(cldfra_bl1D(K),0.5)*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). - - ! dampen the amplification factor (cld_factor) with height in order - ! to limit excessively large cloud fractions aloft - fac_damp = 1. -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & - MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) - !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 - cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 - cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) - ENDDO +! + DO k = kts,kte-1 + dzk = dz(k) + tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) + qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) + END DO +! - END SELECT !end cloudPDF option - !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. - IF (bl_mynn_cloudpdf .LT. 0) THEN - DO k = kts,kte-1 - cldfra_bl1D(k) = 0.0 - qc_bl1D(k) = 0.0 - qi_bl1D(k) = 0.0 - END DO - ENDIF -! - ql(kte) = ql(kte-1) - vt(kte) = vt(kte-1) - vq(kte) = vq(kte-1) - qc_bl1D(kte)=0. - qi_bl1D(kte)=0. - cldfra_bl1D(kte)=0. - RETURN + if (spp_pbl==1) then + DO k = kts,kte + dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + END DO + endif +! RETURN #ifdef HARDCODE_VERTICAL # undef kts # undef kte #endif - END SUBROUTINE mym_condensation + END SUBROUTINE mym_turbulence ! ================================================================== +! SUBROUTINE mym_predict: +! +! Input variables: see subroutine mym_initialize and turbulence +! qke(nx,nz,ny) : qke at (n)th time level +! tsq, ...cov : ditto +! +! Output variables: +! qke(nx,nz,ny) : qke at (n+1)th time level +! tsq, ...cov : ditto +! +! Work arrays: +! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) +! bp (nx,nz,ny) : = 1/2*F, see below +! rp (nx,nz,ny) : = P-1/2*F*Q, see below +! +! # The equation for a turbulent quantity Q can be expressed as +! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) +! where A is the advection, D the diffusion, P the production, +! F*Q the dissipation and h and v denote horizontal and vertical, +! respectively. If Q is q^2, F is 2q/B_1L. +! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite +! difference equation is written as +! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) +! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) +! where n denotes the time level. +! When the advection and diffusion terms are discretized as +! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) +! Eq.(2) can be rewritten as +! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) +! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) +! where Q on the left-hand side is at (n+1)th time level. +! +! In this subroutine, a(k), b(k) and c(k) are obtained from +! subprogram coefvu and are passed to subprogram tinteg via +! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, +! respectively. Subprogram tinteg solves Eq.(4). +! +! Modify this subroutine according to your numerical integration +! scheme (program). +! +!------------------------------------------------------------------- !>\ingroup gsd_mynn_edmf -!! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, -!! qc, and qi - SUBROUTINE mynn_tendencies(kts,kte, & - &closure,grav_settling, & - &delt,dz,rho, & - &u,v,th,tk,qv,qc,qi,qnc,qni, & - &psfc,p,exner, & - &thl,sqv,sqc,sqi,sqw, & - &qnwfa,qnifa,ozone, & - &ust,flt,flq,flqv,flqc,wspd,qcg, & - &uoce,voce, & - &tsq,qsq,cov, & - &tcd,qcd, & - &dfm,dfh,dfq, & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & - &Dqnwfa,Dqnifa,Dozone, & - &vdfg1,diss_heat, & - &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & - &s_awu,s_awv, & - &s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv, & - &sd_awqc,sd_awu,sd_awv, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & - &FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) +!! This subroutine predicts the turbulent quantities at the next step. + SUBROUTINE mym_predict (kts,kte, & + & closure, & + & delt, & + & dz, & + & ust, flt, flq, pmz, phh, & + & el, dfq, rho, & + & pdk, pdt, pdq, pdc, & + & qke, tsq, qsq, cov, & + & s_aw,s_awqke,bl_mynn_edmf_tke, & + & qWT1D, qDISS1D,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte + INTEGER, INTENT(IN) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(in) :: grav_settling - REAL, INTENT(in) :: closure - INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& - bl_mynn_edmf,bl_mynn_edmf_mom, & - bl_mynn_mixscalars - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA - -!! grav_settling = 1 or 2 for gravitational settling of droplets -!! grav_settling = 0 otherwise -! thl - liquid water potential temperature -! qw - total water -! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk -! flt - surface flux of thl -! flq - surface flux of qw - -! mass-flux plumes - REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& - &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & - &s_awqnwfa,s_awqnifa, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv -! tendencies from mass-flux environmental subsidence and detrainment - REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & - &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& - &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& - &qnwfa,qnifa,ozone,dfm,dfh - REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& - &dqni,dqnc,dqnwfa,dqnifa,dozone - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg,psfc - -! REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,& -! &gradu_top,gradv_top,gradth_top,gradqv_top - -!local vars - - REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp - REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING - qnwfa2,qnifa2,ozone2 - REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv + REAL, INTENT(IN) :: closure + INTEGER, INTENT(IN) :: bl_mynn_edmf_tke + REAL, INTENT(IN) :: delt + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc + REAL, INTENT(IN) :: flt, flq, ust, pmz, phh + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov +! WA 8/3/15 + REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + + !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D + LOGICAL, INTENT(IN) :: bl_mynn_tkebudget + REAL, DIMENSION(kts:kte) :: tke_up,dzinv + !! >> EOB + + INTEGER :: k + REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q + REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff + REAL, DIMENSION(kts:kte) :: dtz REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface - & khdz, kmdz - REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: grav_settling2,vdfg1 !Katata-fogdes - REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc - REAL :: ustdrag,ustdiff - REAL :: th_new,portion_qc,portion_qi,condensate,qsat - INTEGER :: k,kk - - !Activate nonlocal mixing from the mass-flux scheme for - !number concentrations and aerosols (0.0 = no; 1.0 = yes) - REAL, PARAMETER :: nonloc = 1.0 - dztop=.5*(dz(kte)+dz(kte-1)) + REAL, DIMENSION(kts:kte) :: rhoinv + REAL, DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) - ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so - ! we only need to zero-out the MF term - IF (bl_mynn_edmf_mom == 0) THEN + IF (bl_mynn_edmf_tke == 0) THEN onoff=0.0 ELSE onoff=1.0 ENDIF +! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = karman*0.5*dz(kts) +! +! ** dfq for the TKE is 3.0*dfm. ** +! + DO k = kts,kte +!! qke(k) = MAX(qke(k), 0.0) + qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) + df3q(k)=Sqfac*dfq(k) + dtz(k)=delt/dz(k) + END DO +! +!JOE-add conservation + stability criteria !Prepare "constants" for diffusion equation. !khdz = rho*Kh/dz = rho*dfh - rhosfc = psfc/(Rd*(Tk(kts)+0.608*qv(kts))) - dtz(kts) =delt/dz(kts) rhoz(kts) =rho(kts) rhoinv(kts)=1./rho(kts) - khdz(kts) =rhoz(kts)*dfh(kts) - kmdz(kts) =rhoz(kts)*dfm(kts) - delp(kts) = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1)) + kqdz(kts) =rhoz(kts)*df3q(kts) + kmdz(kts) =rhoz(kts)*dfq(kts) DO k=kts+1,kte - dtz(k) =delt/dz(k) rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) rhoz(k) = MAX(rhoz(k),1E-4) rhoinv(k)=1./MAX(rho(k),1E-4) - dzk = 0.5 *( dz(k)+dz(k-1) ) - khdz(k) = rhoz(k)*dfh(k) - kmdz(k) = rhoz(k)*dfm(k) - ENDDO - DO k=kts+1,kte-1 - delp(k) = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - & - (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1)) + kqdz(k) = rhoz(k)*df3q(k) ! for TKE + kmdz(k) = rhoz(k)*dfq(k) ! for T'2, q'2, and T'q' ENDDO - delp(kte) =delp(kte-1) rhoz(kte+1)=rhoz(kte) - khdz(kte+1)=rhoz(kte+1)*dfh(kte) - kmdz(kte+1)=rhoz(kte+1)*dfm(kte) + kqdz(kte+1)=rhoz(kte+1)*df3q(kte) + kmdz(kte+1)=rhoz(kte+1)*dfq(kte) !stability criteria for mf DO k=kts+1,kte-1 - khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) - khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - kmdz(k) = MAX(kmdz(k), 0.5*s_aw(k)) + kqdz(k) = MAX(kqdz(k), 0.5* s_aw(k)) + kqdz(k) = MAX(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO +!JOE-end conservation mods - ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s - ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s - dth(kts:kte) = 0.0 ! must initialize for moisture_check routine - -!!============================================ -!! u -!!============================================ - - k=kts - -!original approach -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & -! sub_u(k)*delt + det_u(k)*delt + pdk1 = 2.0*ust**3*pmz/( vkz ) + phm = 2.0/ust *phh/( vkz ) + pdt1 = phm*flt**2 + pdq1 = phm*flq**2 + pdc1 = phm*flt*flq +! +! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. ** + pdk(kts) = pdk1 -pdk(kts+1) -!rho-weighted: -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1)+ust**2/wspd)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & -! & sub_u(k)*delt + det_u(k)*delt +!! pdt(kts) = pdt1 -pdt(kts+1) +!! pdq(kts) = pdq1 -pdq(kts+1) +!! pdc(kts) = pdc1 -pdc(kts+1) + pdt(kts) = pdt(kts+1) + pdq(kts) = pdq(kts+1) + pdc(kts) = pdc(kts+1) +! +! ** Prediction of twice the turbulent kinetic energy ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b1l = b1*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b1l + rp(k) = pdk(k+1) + pdk(k) + END DO -!rho-weighted with drag term moved out of b-array - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & - !d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & - & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & - & sub_u(k)*delt + det_u(k)*delt +! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. + DO k=kts,kte-1 +! a(k-kts+1)=-dtz(k)*df3q(k) +! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt +! c(k-kts+1)=-dtz(k)*df3q(k+1) +! d(k-kts+1)=rp(k)*delt + qke(k) +! WA 8/3/15 add EDMF contribution +! a(k)= - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff +! b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & +! + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt +! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kqdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + bp(k)*delt + c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff + d(k)=rp(k)*delt + qke(k) & + & + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff ENDDO -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*df3q(k) +!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) +!! c(k-kts+1)=-dtz(k)*df3q(k+1) +!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt +!! ENDDO -!! specified gradient at the top -! a(kte)=-1. +!! "no flux at top" +! a(kte)=-1. !0. ! b(kte)=1. ! c(kte)=0. -! d(kte)=gradu_top*dztop - -!! prescribed value - a(kte)=0 +! d(kte)=0. +!! "prescribed value" + a(kte)=0. b(kte)=1. c(kte)=0. - d(kte)=u(kte) + d(kte)=qke(kte) ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) DO k=kts,kte -! du(k)=(d(k-kts+1)-u(k))/delt - du(k)=(x(k)-u(k))/delt +! qke(k)=max(d(k-kts+1), 1.e-4) + qke(k)=max(x(k), 1.e-4) + qke(k)=min(qke(k), 150.) ENDDO + + +!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + IF (bl_mynn_tkebudget) THEN + !! TKE Vertical transport << EOBvt + tke_up=0.5*qke + dzinv=1./dz + k=kts + qWT1D(k)=dzinv(k)*( & + & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) & + & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & + & + (s_aw(k+1)-s_aw(k))*tke_up(k) & + & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + DO k=kts+1,kte-1 + qWT1D(k)=dzinv(k)*( & + & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) & + & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & + & + (s_aw(k+1)-s_aw(k))*tke_up(k) & + & - s_aw(k)*tke_up(k-1) & + & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + ENDDO + k=kte + qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & + & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared + !! >> EOBvt + qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered + END IF +!! >> EOB + + IF ( closure > 2.5 ) THEN -!!============================================ -!! v -!!============================================ - - k=kts + ! ** Prediction of the moisture variance ** + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdq(k+1) + pdq(k) + END DO -!original approach -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & -! sub_v(k)*delt + det_v(k)*delt + !zero gradient for qsq at bottom and top + !a(1)=0. + !b(1)=1. + !c(1)=-1. + !d(1)=0. -!rho-weighted: -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1)+ust**2/wspd)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & -! & sub_v(k)*delt + det_v(k)*delt + ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + qsq(k) + ENDDO -!rho-weighted with drag term moved out of b-array - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & - !d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & - & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & - & sub_v(k)*delt + det_v(k)*delt - ENDDO +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte + !qsq(k)=d(k-kts+1) + qsq(k)=MAX(x(k),1e-12) + ENDDO + ELSE + !level 2.5 - use level 2 diagnostic + DO k = kts,kte-1 + IF ( qkw(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) + END IF + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + END DO + qsq(kte)=qsq(kte-1) + END IF +!!!!!!!!!!!!!!!!!!!!!!end level 2.6 -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. + IF ( closure .GE. 3.0 ) THEN +! +! ** dfq for the scalar variance is 1.0*dfm. ** +! +! ** Prediction of the temperature variance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdt(k+1) + pdt(k) + END DO + +!zero gradient for tsq at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. -!! specified gradient at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradv_top*dztop +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + !a(k-kts+1)=-dtz(k)*dfq(k) + !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + !c(k-kts+1)=-dtz(k)*dfq(k+1) + !d(k-kts+1)=rp(k)*delt + tsq(k) +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + tsq(k) + ENDDO -!! prescribed value - a(kte)=0 - b(kte)=1. - c(kte)=0. - d(kte)=v(kte) +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt +!! ENDDO -! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) - DO k=kts,kte -! dv(k)=(d(k-kts+1)-v(k))/delt - dv(k)=(x(k)-v(k))/delt - ENDDO + DO k=kts,kte +! tsq(k)=d(k-kts+1) + tsq(k)=x(k) + ENDDO -!!============================================ -!! thl tendency -!! NOTE: currently, gravitational settling is removed -!!============================================ - k=kts +! ** Prediction of the temperature-moisture covariance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdc(k+1) + pdc(k) + END DO + +!zero gradient for tqcov at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & -! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt*dheat_opt + & -! & sub_thl(k)*delt + det_thl(k)*delt +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + !a(k-kts+1)=-dtz(k)*dfq(k) + !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + !c(k-kts+1)=-dtz(k)*dfq(k+1) + !d(k-kts+1)=rp(k)*delt + cov(k) +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + cov(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! cov(k)=d(k-kts+1) + cov(k)=x(k) + ENDDO + + ELSE + + !Not level 3 - default to level 2 diagnostic + DO k = kts,kte-1 + IF ( qkw(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) + END IF ! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & -! & + diss_heat(k)*delt*dheat_opt + & -! & sub_thl(k)*delt + det_thl(k)*delt -! ENDDO + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO + + tsq(kte)=tsq(kte-1) + cov(kte)=cov(kte-1) + + END IF -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + & - & diss_heat(k)*delt*dheat_opt + sub_thl(k)*delt + det_thl(k)*delt +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=thl(k) + tcd(k)*delt + & - & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + & - & diss_heat(k)*delt*dheat_opt + & - & sub_thl(k)*delt + det_thl(k)*delt - ENDDO + END SUBROUTINE mym_predict + +! ================================================================== +! SUBROUTINE mym_condensation: +! +! Input variables: see subroutine mym_initialize and turbulence +! exner(nz) : Perturbation of the Exner function (J/kg K) +! defined on the walls of the grid boxes +! This is usually computed by integrating +! d(pi)/dz = h*g*tv/tref**2 +! from the upper boundary, where tv is the +! virtual potential temperature minus tref. +! +! Output variables: see subroutine mym_initialize +! cld(nx,nz,ny) : Cloud fraction +! +! Work arrays: +! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation +! specific humidity at T=Tl +! alp(nx,nz,ny) : Functions in the condensation process +! bet(nx,nz,ny) : ditto +! sgm(nx,nz,ny) : Combined standard deviation sigma_s +! multiplied by 2/alp +! +! # qmq, alp, bet and sgm are allowed to share storage units with +! any four of other work arrays for saving memory. +! +! # Results are sensitive particularly to values of cp and r_d. +! Set these values to those adopted by you. +! +!------------------------------------------------------------------- +!>\ingroup gsd_mynn_edmf +!! This subroutine calculates the nonconvective component of the +!! subgrid cloud fraction and mixing ratio as well as the functions used to +!! calculate the buoyancy flux. Different cloud PDFs can be selected by +!! use of the namelist parameter \p bl_mynn_cloudpdf . + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, zw, & + & thl, qw, qv, qc, qi, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf,& + & qc_bl1D, qi_bl1D, & + & cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm, rmo, & + & spp_pbl,rstoch_col ) -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. +!------------------------------------------------------------------- -!! specified gradient at the top -!assume gradthl_top=gradth_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradth_top*dztop + INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=thl(kte) +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, & + &tsq, qsq, cov, th - DO k=kts,kte - !thl(k)=d(k-kts+1) - thl(k)=x(k) - ENDDO + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm -IF (bl_mynn_mixqt > 0) THEN - !============================================ - ! MIX total water (sqw = sqc + sqv + sqi) - ! NOTE: no total water tendency is output; instead, we must calculate - ! the saturation specific humidity and then - ! subtract out the moisture excess (sqc & sqi) - !============================================ + REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,RH + REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & + cldfra_bl1D + DOUBLE PRECISION :: t3sq, r3sq, c3sq - k=kts + REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,qlk,eq1,qll,& + &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,& + &ls_min,ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& + &low_weight + INTEGER :: i,j,k -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& -! d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) -! ENDDO + REAL :: erf -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqt(k+1) - dtz(k)*rhoinv(k)*sd_awqt(k+1) + !VARIABLES FOR ALTERNATIVE SIGMA + REAL::dth,dtl,dqw,dzk,els + REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqw(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*rhoinv(k)*(sd_awqt(k)-sd_awqt(k+1)) - ENDDO + !variables for SGS BL clouds + REAL :: zagl,damp,PBLH2 + REAL :: lfac + INTEGER, PARAMETER :: sig_order = 2 !sigma form, 1: use state variables, 2: higher-order variables -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqw(kte) + !JAYMES: variables for tropopause-height estimation + REAL :: theta1, theta2, ht1, ht2 + INTEGER :: k_tropo -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqw2) - CALL tridiag3(kte,a,b,c,d,sqw2) +! Stochastic + INTEGER, INTENT(IN) :: spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col + REAL :: qw_pert -! DO k=kts,kte -! sqw2(k)=d(k-kts+1) -! ENDDO -ELSE - sqw2=sqw -ENDIF +! First, obtain an estimate for the tropopause height (k), using the method employed in the +! Thompson subgrid-cloud scheme. This height will be a consideration later when determining +! the "final" subgrid-cloud properties. +! JAYMES: added 3 Nov 2016, adapted from G. Thompson -IF (bl_mynn_mixqt == 0) THEN -!============================================ -! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), -! then sqc will be backed out of saturation check (below). -!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN + DO k = kte-3, kts, -1 + theta1 = th(k) + theta2 = th(k+2) + ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) + ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) + if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & + & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, k+2) - k=kts + zagl = 0. -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - & -! dtz(k)*s_awqc(k+1) + det_sqc(k)*delt -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + & -! det_sqc(k)*delt -! ENDDO + SELECT CASE(bl_mynn_cloudpdf) -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + & - & det_sqc(k)*delt + CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqc(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*rhoinv(k)*(sd_awqc(k)-sd_awqc(k+1)) + & - & det_sqc(k)*delt - ENDDO + DO k = kts,kte-1 + t = th(k)*exner(k) -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqc(kte) +!x if ( ct .gt. 0.0 ) then +! a = 17.27 +! b = 237.3 +!x else +!x a = 21.87 +!x b = 265.5 +!x end if +! +! ** 3.8 = 0.622*6.11 (hPa) ** -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqc2) - CALL tridiag3(kte,a,b,c,d,sqc2) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*xlv/( r_d*t**2 ) -! DO k=kts,kte -! sqc2(k)=d(k-kts+1) -! ENDDO - ELSE - !If not mixing clouds, set "updated" array equal to original array - sqc2=sqc - ENDIF -ENDIF + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) -IF (bl_mynn_mixqt == 0) THEN - !============================================ - ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), - ! then sqv will be backed out of saturation check (below). - !============================================ + !Sommeria and Deardorff (1977) scheme, as implemented + !in Nakanishi and Niino (2009), Appendix B + t3sq = MAX( tsq(k), 0.0 ) + r3sq = MAX( qsq(k), 0.0 ) + c3sq = cov(k) + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) + r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq + !DEFICIT/EXCESS WATER CONTENT + qmq(k) = qw(k) -qsl + !ORIGINAL STANDARD DEVIATION + sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) + !NORMALIZED DEPARTURE FROM SATURATION + q1(k) = qmq(k) / sgm(k) + !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 + cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - k=kts + q1k = q1(k) + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql(k) = alp(k)*sgm(k)*qll + !LIMIT SPECIES TO TEMPERATURE RANGES + liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) + qc_bl1D(k) = liq_frac*ql(k) + qi_bl1D(k) = (1.0 - liq_frac)*ql(k) -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + & -! & sub_sqv(k)*delt + det_sqv(k)*delt -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + & -! & sub_sqv(k)*delt + det_sqv(k)*delt -! ENDDO + if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 + if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + & - & sub_sqv(k)*delt + det_sqv(k)*delt + !Now estimate the buoyancy flux functions + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) - d(k)=sqv(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*rhoinv(k)*(sd_awqv(k)-sd_awqv(k+1)) + & - & sub_sqv(k)*delt + det_sqv(k)*delt - ENDDO + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) + rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) -! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac -! specified gradient at the top -! assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop + END DO -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqv(kte) + CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and + !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*xlv/( r_d*t**2 ) -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqv2) - CALL tridiag3(kte,a,b,c,d,sqv2) + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) -! DO k=kts,kte -! sqv2(k)=d(k-kts+1) -! ENDDO -ELSE - sqv2=sqv -ENDIF + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = dz(k) + end if + dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & + b2 * MAX(Sh(k),0.03))/4. * & + (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) + qmq(k) = qw(k) -qsl + q1(k) = qmq(k) / sgm(k) + cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) -!============================================ -! MIX CLOUD ICE ( sqi ) -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN + !now compute estimated lwc for PBL scheme's use + !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and + !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 + q1k = q1(k) + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(K)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) + qc_bl1D(k) = liq_frac*ql(k) + qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - k=kts + if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 + if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt -! ENDDO + !Now estimate the buoyancy flux functions + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqi(k) + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) + rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqi(k) - ENDDO + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. + END DO -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop + CASE (2, -2) -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqi(kte) + if (sig_order == 1) then + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !using the first-order version of sigma (their eq. 5). + !JAYMES- this added 27 Apr 2015 + PBLH2=MAX(10.,PBLH1) + zagl = 0. + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*xlv/( r_d*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqi2) - CALL tridiag3(kte,a,b,c,d,sqi2) + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) -! DO k=kts,kte -! sqi2(k)=d(k-kts+1) -! ENDDO -ELSE - sqi2=sqi -ENDIF + xl = xl_blend(t) ! obtain latent heat + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + qmq(k) = a(k) * (qw_pert - qsat_tl) + b(k) = a(k)*rsl ! CB02 variable "b" + + dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & + & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) -!!============================================ -!! cloud ice number concentration (qni) -!!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. & - bl_mynn_mixscalars > 0) THEN + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = dz(k) + end if - k=kts + cdhdz = dtl/dzk + (grav/cpm)*(1.+qw(k)) ! expression below Eq. 9 + ! in CB02 + zagl = zagl + dz(k) + !Use analog to surface layer length scale to make the cloud mixing length scale + !become less than z in stable conditions. + els = zagl !save for more testing: /(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qni(k) - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc + !ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) + ls_min = 300. + MIN(2.*MAX(HFX1,0.),150.) + ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: + if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) + ! 25 m < ls_min(=zagl) < 300 m + lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: + ! lfac(750 m) = 4.4 + ! lfac(3 km) = 5.0 + ! lfac(13 km) = 6.0 + ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m + ! Note: CB02 use 900 m as a constant free-atmosphere length scale. - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc - ENDDO + ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the + ! MYNN master length scale (el) must exceed 60 m before ls + ! becomes responsive to el, otherwise ls = ls_min = 300 m. -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qni(kte) + sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: + & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, + & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, + & +b(k)**2 * cdhdz**2))) ! < 3rd term + ! CB02 use a multiplier of 0.2, but 0.225 is chosen + ! based on tests -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + END DO - DO k=kts,kte - !qni2(k)=d(k-kts+1) - qni2(k)=x(k) - ENDDO + else -ELSE - qni2=qni -ENDIF + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !but with use of higher-order moments to estimate sigma + PBLH2=MAX(10.,PBLH1) + zagl = 0. + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*xlv/( r_d*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) -!!============================================ -!! cloud water number concentration (qnc) -!! include non-local transport -!!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & - bl_mynn_mixscalars > 0) THEN + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) - k=kts + xl = xl_blend(t) ! obtain latent heat + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b(k) = a(k)*rsl ! CB02 variable "b" - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc - ENDDO + !This form of qmq (the numerator of Q1) no longer uses the a(k) factor + qmq(k) = qw_pert - qsat_tl ! saturation deficit/excess; -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnc(kte) + !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) + !except neglect all but the first term for sig_r + r3sq = MAX( qsq(k), 0.0 ) + !Calculate sigma using higher-order moments: + sgm(k) = SQRT( r3sq ) + !Set limits on sigma relative to saturation water vapor + sgm(k) = MIN( sgm(k), qsat_tl*0.666 ) !500 ) + sgm(k) = MAX( sgm(k), qsat_tl*0.050 ) !Note: 0.02 results in SWDOWN similar + !to the first-order version of sigma + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + !This form only allows cloud fractions out to q1 = -1.8 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) + !This form only allows cloud fractions out to q1 = -1 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) - DO k=kts,kte - !qnc2(k)=d(k-kts+1) - qnc2(k)=x(k) - ENDDO + END DO -ELSE - qnc2=qnc -ENDIF + endif !end sig_order option -!============================================ -! Water-friendly aerosols ( qnwfa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. & - bl_mynn_mixscalars > 0) THEN + ! Specify hydrometeors + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. + ! "fng" represents the non-Gaussian contribution to the liquid + ! water flux; these formulations are from Cuijpers and Bechtold + ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, + ! hereafter BCMT95 + zagl = 0. + DO k = kts,kte-1 + t = th(k)*exner(k) + q1k = q1(k) + zagl = zagl + dz(k) - k=kts + !CLOUD WATER AND ICE + IF (q1k < 0.) THEN !unsaturated + ql_water = sgm(k)*EXP(1.2*q1k-1) + ql_ice = sgm(k)*EXP(1.2*q1k-1.) + !Reduce ice mixing ratios in the upper troposphere +! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 +! ql_ice = low_weight * sgm(k)*EXP(1.1*q1k-1.6) & !low-lev +! + (1.-low_weight) * sgm(k)*EXP(1.1*q1k-2.8)!upper-lev + ELSE IF (q1k > 2.) THEN !supersaturated + ql_water = sgm(k)*q1k + ql_ice = sgm(k)*q1k + !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*q1k + ELSE !slightly saturated (0 > q1 < 2) + ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + ENDIF - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & - & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc + !In saturated grid cells, use average of current estimate and prev time step + IF ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) + IF ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc - ENDDO + IF (cldfra_bl1D(k) < 0.01) THEN + ql_ice = 0.0 + ql_water = 0.0 + cldfra_bl1D(k) = 0.0 + ENDIF -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnwfa(kte) + !PHASE PARTITIONING: Make some inferences about the relative amounts of + !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, + !use a simple temperature-dependent partitioning. +! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning +! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid +! liq_frac = 1.0 +! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice +! liq_frac = 0.0 +! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably +! ! large amounts; assume subgrid follows +! ! same partioning +! liq_frac = qc(k) / ( qc(k) + qi(k) ) +! ELSE +! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one +! ! species is very small, so make a temperature- +! ! depedent guess +! ENDIF +! ELSE ! no explicit condensate, so make a temperature-dependent guess + liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) +! ENDIF -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice + qi_bl1D(k) = (1.0-liq_frac)*ql_ice - DO k=kts,kte - !qnwfa2(k)=d(k) - qnwfa2(k)=x(k) - ENDDO + !Above tropopause: eliminate subgrid clouds from CB scheme + if (k .ge. k_tropo-1) then + cldfra_bl1D(K) = 0. + qc_bl1D(k) = 0. + qi_bl1D(k) = 0. + endif + ENDDO -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnwfa2=qnwfa -ENDIF + !Buoyancy-flux-related calculations follow... + DO k = kts,kte-1 + t = th(k)*exner(k) -!============================================ -! Ice-friendly aerosols ( qnifa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN + ! "Fng" represents the non-Gaussian transport factor + ! (non-dimensional) from Bechtold et al. 1995 + ! (hereafter BCMT95), section 3(c). Their suggested + ! forms for Fng (from their Eq. 20) are: + !IF (q1k < -2.) THEN + ! Fng = 2.-q1k + !ELSE IF (q1k > 0.) THEN + ! Fng = 1. + !ELSE + ! Fng = 1.-1.5*q1k + !ENDIF + !limiting to avoid mixing away stratus, was -5 + q1k=MAX(Q1(k),-1.0) + IF (q1k .GE. 1.0) THEN + Fng = 1.0 + ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN + Fng = EXP(-0.4*(q1k-1.0)) + ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN + Fng = 3.0 + EXP(-3.8*(q1k+1.7)) + ELSE + Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) + ENDIF + Fng = MIN(Fng, 20.) - k=kts + xl = xl_blend(t) + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + vt(k) = qww - MIN(cldfra_bl1D(K),0.5)*beta*bb*Fng - 1. + vq(k) = alpha + MIN(cldfra_bl1D(K),0.5)*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & - & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc + ! dampen the amplification factor (cld_factor) with height in order + ! to limit excessively large cloud fractions aloft + fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & + ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) + !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 + cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 + cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.21 )**2 + cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) + ENDDO - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc - ENDDO + END SELECT !end cloudPDF option -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnifa(kte) + !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + IF (bl_mynn_cloudpdf .LT. 0) THEN + DO k = kts,kte-1 + cldfra_bl1D(k) = 0.0 + qc_bl1D(k) = 0.0 + qi_bl1D(k) = 0.0 + END DO + ENDIF +! + ql(kte) = ql(kte-1) + vt(kte) = vt(kte-1) + vq(kte) = vq(kte-1) + qc_bl1D(kte)=0. + qi_bl1D(kte)=0. + cldfra_bl1D(kte)=0. + RETURN -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif - DO k=kts,kte - !qnifa2(k)=d(k-kts+1) - qnifa2(k)=x(k) - ENDDO + END SUBROUTINE mym_condensation -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnifa2=qnifa -ENDIF +! ================================================================== +!>\ingroup gsd_mynn_edmf +!! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, +!! qc, and qi + SUBROUTINE mynn_tendencies(kts,kte,i, & + &closure, & + &delt,dz,rho, & + &u,v,th,tk,qv,qc,qi,qnc,qni, & + &psfc,p,exner, & + &thl,sqv,sqc,sqi,sqw, & + &qnwfa,qnifa,ozone, & + &ust,flt,flq,flqv,flqc,wspd, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & + &Dqnwfa,Dqnifa,Dozone, & + &vdfg1,diss_heat, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv, & + &sd_awqc,sd_awu,sd_awv, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & + &FLAG_QNWFA,FLAG_QNIFA, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) -!============================================ -! Ozone - local mixing only -!============================================ +!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kts,kte,i - k=kts +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=ozone(k) + REAL, INTENT(in) :: closure + INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& + bl_mynn_edmf,bl_mynn_edmf_mom, & + bl_mynn_mixscalars + LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + FLAG_QNWFA,FLAG_QNIFA - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=ozone(k) - ENDDO +! thl - liquid water potential temperature +! qw - total water +! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk +! flt - surface flux of thl +! flq - surface flux of qw -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=ozone(kte) +! mass-flux plumes + REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& + &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & + &s_awqnwfa,s_awqnifa, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv +! tendencies from mass-flux environmental subsidence and detrainment + REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & + &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& + &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat + REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& + &qnwfa,qnifa,ozone,dfm,dfh + REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& + &dqni,dqnc,dqnwfa,dqnifa,dozone + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,& + &psfc + !debugging + REAL ::wsp,wsp2 + LOGICAL :: problem + integer :: kproblem -! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) +! REAL, INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top - DO k=kts,kte - !ozone2(k)=d(k-kts+1) - dozone(k)=(x(k)-ozone(k))/delt +!local vars + + REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp + REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING + qnwfa2,qnifa2,ozone2 + REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv + REAL, DIMENSION(kts:kte) :: a,b,c,d,x + REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface + & khdz, kmdz + REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw + REAL :: vdfg1 !Katata-fogdes + REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc + REAL :: ustdrag,ustdiff,qvflux + REAL :: th_new,portion_qc,portion_qi,condensate,qsat + INTEGER :: k,kk + + !Activate nonlocal mixing from the mass-flux scheme for + !number concentrations and aerosols (0.0 = no; 1.0 = yes) + REAL, PARAMETER :: nonloc = 1.0 + + dztop=.5*(dz(kte)+dz(kte-1)) + + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so + ! we only need to zero-out the MF term + IF (bl_mynn_edmf_mom == 0) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz = rho*dfh + rhosfc = psfc/(R_d*(tk(kts)+p608*qv(kts))) + dtz(kts) =delt/dz(kts) + rhoz(kts) =rho(kts) + rhoinv(kts)=1./rho(kts) + khdz(kts) =rhoz(kts)*dfh(kts) + kmdz(kts) =rhoz(kts)*dfm(kts) + delp(kts) = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1)) + DO k=kts+1,kte + dtz(k) =delt/dz(k) + rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + rhoz(k) = MAX(rhoz(k),1E-4) + rhoinv(k)=1./MAX(rho(k),1E-4) + dzk = 0.5 *( dz(k)+dz(k-1) ) + khdz(k) = rhoz(k)*dfh(k) + kmdz(k) = rhoz(k)*dfm(k) + ENDDO + DO k=kts+1,kte-1 + delp(k) = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - & + (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1)) + ENDDO + delp(kte) =delp(kte-1) + rhoz(kte+1)=rhoz(kte) + khdz(kte+1)=rhoz(kte+1)*dfh(kte) + kmdz(kte+1)=rhoz(kte+1)*dfm(kte) + + !stability criteria for mf + DO k=kts+1,kte-1 + khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) + khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + kmdz(k) = MAX(kmdz(k), 0.5*s_aw(k)) + kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO + ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s + ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s + dth(kts:kte) = 0.0 ! must initialize for moisture_check routine + !!============================================ -!! Compute tendencies and convert to mixing ratios for WRF. -!! Note that the momentum tendencies are calculated above. +!! u !!============================================ - IF (bl_mynn_mixqt > 0) THEN - DO k=kts,kte - !compute updated theta using updated thl and old condensate - th_new = thl(k) + xlvcp/exner(k)*sqc(k) & - & + xlscp/exner(k)*sqi(k) + k=kts - t = th_new*exner(k) - qsat = qsat_blend(t,p(k)) - !SATURATED VAPOR PRESSURE - !esat=esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) +!original approach (drag in b-vector): +! a(1)=0. +! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & +! sub_u(k)*delt + det_u(k)*delt - IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated - sqv2(k) = MIN(sqw2(k),qsat) - portion_qc = sqc(k)/(sqc(k) + sqi(k)) - portion_qi = sqi(k)/(sqc(k) + sqi(k)) - condensate = MAX(sqw2(k) - qsat, 0.0) - sqc2(k) = condensate*portion_qc - sqi2(k) = condensate*portion_qi - ELSE ! initially unsaturated ----- - sqv2(k) = sqw2(k) ! let microphys decide what to do - sqi2(k) = 0.0 ! if sqw2 > qsat - sqc2(k) = 0.0 - ENDIF - !dqv(k) = (sqv2(k) - sqv(k))/delt - !dqc(k) = (sqc2(k) - sqc(k))/delt - !dqi(k) = (sqi2(k) - sqi(k))/delt - ENDDO - ENDIF +!rho-weighted (drag in b-vector): + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - & + & dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt +!rho-weighted with drag term moved out of b-array +! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) +! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff +! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff +! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & +! !!!d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & +! & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - !===================== - ! WATER VAPOR TENDENCY - !===================== - DO k=kts,kte - Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt - !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k + DO k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & + & sub_u(k)*delt + det_u(k)*delt ENDDO - IF (bl_mynn_cloudmix > 0) THEN - !===================== - ! CLOUD WATER TENDENCY - !===================== - !qc fog settling tendency is now computed in module_bl_fogdes.F, so - !sqc should only be changed by eddy diffusion or mass-flux. - !print*,"FLAG_QC:",FLAG_QC - IF (FLAG_QC) THEN - DO k=kts,kte - Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt - !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k - ENDDO - ELSE - DO k=kts,kte - Dqc(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD WATER NUM CONC TENDENCY - !=================== - IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqnc(k) = (qnc2(k)-qnc(k))/delt - !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqnc(k) = 0. - ENDDO - ENDIF +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. - !=================== - ! CLOUD ICE TENDENCY - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt - !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k - ENDDO - ELSE - DO k=kts,kte - Dqi(k) = 0. - ENDDO - ENDIF +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradu_top*dztop - !=================== - ! CLOUD ICE NUM CONC TENDENCY - !=================== - IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqni(k)=(qni2(k)-qni(k))/delt - !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqni(k)=0. - ENDDO - ENDIF - ELSE !-MIX CLOUD SPECIES? - !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) - DO k=kts,kte - Dqc(k)=0. - Dqnc(k)=0. - Dqi(k)=0. - Dqni(k)=0. - ENDDO - ENDIF +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=u(kte) - !ensure non-negative moist species - CALL moisture_check(kte, delt, delp, exner, & - sqv2, sqc2, sqi2, thl, & - dqv, dqc, dqi, dth ) +! CALL tridiag(kte,a,b,c,d) + CALL tridiag3(kte,a,b,c,d,x) - !===================== - ! OZONE TENDENCY CHECK - !===================== DO k=kts,kte - IF(Dozone(k)*delt + ozone(k) < 0.) THEN - Dozone(k)=-ozone(k)*0.99/delt - ENDIF +! du(k)=(d(k-kts+1)-u(k))/delt + du(k)=(x(k)-u(k))/delt ENDDO - !=================== - ! THETA TENDENCY - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & - & + xlscp/exner(k)*sqi2(k) & - & - th(k))/delt - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy: - !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k) & - ! & + xlscp/MAX(tk(k),TKmin)*sqi(k)) & - ! & - th(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)) & - !& - th(k))/delt - ENDDO - ENDIF +!!============================================ +!! v +!!============================================ - !=================== - ! AEROSOL TENDENCIES - !=================== - IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - !===================== - ! WATER-friendly aerosols - !===================== - Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt - !===================== - ! Ice-friendly aerosols - !===================== - Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqnwfa(k)=0. - Dqnifa(k)=0. - ENDDO - ENDIF + k=kts - !ensure non-negative moist species - !note: if called down here, dth needs to be updated, but - ! if called before the theta-tendency calculation, do not compute dth - !CALL moisture_check(kte, delt, delp, exner, & - ! sqv, sqc, sqi, thl, & - ! dqv, dqc, dqi, dth ) +!original approach (drag in b-vector): +! a(1)=0. +! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & +! sub_v(k)*delt + det_v(k)*delt -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif +!rho-weighted (drag in b-vector): + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + & + & sub_v(k)*delt + det_v(k)*delt - END SUBROUTINE mynn_tendencies +!rho-weighted with drag term moved out of b-array +! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) +! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff +! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff +! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & +! !!!d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & +! & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt -! ================================================================== - SUBROUTINE moisture_check(kte, delt, dp, exner, & - qv, qc, qi, th, & - dqv, dqc, dqi, dth ) + DO k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & + & sub_v(k)*delt + det_v(k)*delt + ENDDO - ! This subroutine was adopted from the CAM-UW ShCu scheme and - ! adapted for use here. - ! - ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, - ! force them to be larger than minimum value by (1) condensating - ! water vapor into liquid or ice, and (2) by transporting water vapor - ! from the very lower layer. - ! - ! We then update the final state variables and tendencies associated - ! with this correction. If any condensation happens, update theta too. - ! Note that (qv,qc,qi,th) are the final state variables after - ! applying corresponding input tendencies and corrective tendencies. +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. - implicit none - integer, intent(in) :: kte - real, intent(in) :: delt - real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th - real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth - integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum - real, parameter :: qvmin = 1e-20, & - qcmin = 0.0, & - qimin = 0.0 +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradv_top*dztop - do k = kte, 1, -1 ! From the top to the surface - dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) - dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=v(kte) - !fix tendencies - dqc(k) = dqc(k) + dqc2/delt - dqi(k) = dqi(k) + dqi2/delt - dqv(k) = dqv(k) - (dqc2+dqi2)/delt - dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & - xlscp/exner(k)*(dqi2/delt) - !update species - qc(k) = qc(k) + dqc2 - qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 - th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - xlscp/exner(k)*dqi2 +! CALL tridiag(kte,a,b,c,d) + CALL tridiag3(kte,a,b,c,d,x) - !then fix qv - dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) - dqv(k) = dqv(k) + dqv2/delt - qv(k) = qv(k) + dqv2 - if( k .ne. 1 ) then - qv(k-1) = qv(k-1) - dqv2*dp(k)/dp(k-1) - dqv(k-1) = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt - endif - qv(k) = max(qv(k),qvmin) - qc(k) = max(qc(k),qcmin) - qi(k) = max(qi(k),qimin) - end do - ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally - ! extracted from all the layers that has 'qv > 2*qvmin'. This fully - ! preserves column moisture. - if( dqv2 .gt. 1.e-20 ) then - sum = 0.0 - do k = 1, kte - if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) - enddo - aa = dqv2*dp(1)/max(1.e-20,sum) - if( aa .lt. 0.5 ) then - do k = 1, kte - if( qv(k) .gt. 2.0*qvmin ) then - dum = aa*qv(k) - qv(k) = qv(k) - dum - dqv(k) = dqv(k) - dum/delt - endif - enddo - else - ! For testing purposes only (not yet found in any output): - ! write(*,*) 'Full moisture conservation is impossible' - endif - endif + DO k=kts,kte +! dv(k)=(d(k-kts+1)-v(k))/delt + dv(k)=(x(k)-v(k))/delt + ENDDO - return +!!============================================ +!! thl tendency +!!============================================ + k=kts - END SUBROUTINE moisture_check +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & +! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt + & +! & sub_thl(k)*delt + det_thl(k)*delt +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & +! & + diss_heat(k)*delt + & +! & sub_thl(k)*delt + det_thl(k)*delt +! ENDDO -! ================================================================== -#if (WRF_CHEM == 1) - SUBROUTINE mynn_mix_chem(kts,kte,i, & - grav_settling, & - delt,dz,pblh, & - nchem, kdvel, ndvel, num_vert_mix, & - chem1, vd1, & - qnc,qni, & - p,exner, & - thl,sqv,sqc,sqi,sqw,rho, & - ust,flt,flq,flqv,flqc,wspd,qcg, & - tcd,qcd, & - dfm,dfh,dfq, & - s_aw, & - s_awchem, & - bl_mynn_cloudmix, & - emis_ant_no, & - frp_mean, & - enh_vermix ) +!rho-weighted: rhosfc*X*rhoinv(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=thl(k) + dtz(k)*rhosfc*flt*rhoinv(k) + tcd(k)*delt & + & - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + & + & diss_heat(k)*delt + sub_thl(k)*delt + det_thl(k)*delt -!------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i - INTEGER, INTENT(in) :: grav_settling - INTEGER, INTENT(in) :: bl_mynn_cloudmix + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=thl(k) + tcd(k)*delt + & + & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + & + & diss_heat(k)*delt + & + & sub_thl(k)*delt + det_thl(k)*delt + ENDDO - REAL, DIMENSION(kts:kte), INTENT(IN) :: qni,qnc,& - &p,exner,dfm,dfh,dfq,dz,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi,rho - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,qcg - INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix - REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw - REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 - REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 - REAL, INTENT(IN) :: emis_ant_no,frp_mean,pblh - LOGICAL, INTENT(IN) :: enh_vermix -!local vars +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d,x - REAL :: rhs,gfluxm,gfluxp,dztop - REAL :: t,esl,qsl,dzk - REAL :: hght - REAL :: khdz_old, khdz_back - INTEGER :: k,kk - INTEGER :: ic ! Chemical array loop index - - INTEGER, SAVE :: icall +!! specified gradient at the top +!assume gradthl_top=gradth_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradth_top*dztop - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,khdz - REAL, PARAMETER :: no_threshold = 0.1 - REAL, PARAMETER :: frp_threshold = 0.0 - REAL, PARAMETER :: pblh_threshold = 250.0 +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=thl(kte) - dztop=.5*(dz(kte)+dz(kte-1)) +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte - dtz(k)=delt/dz(k) - ENDDO - - !Prepare "constants" for diffusion equation. - !khdz = rho*Kh/dz = rho*dfh - rhoz(kts) =rho(kts) - rhoinv(kts)=1./rho(kts) - khdz(kts) =rhoz(kts)*dfh(kts) -! JLS - khdz_old = khdz(kts) - khdz_back = pblh * 0.15 / dz(kts) - IF ( enh_vermix ) THEN - IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > no_threshold ) THEN - khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - IF ( frp_mean > frp_threshold ) THEN - khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - ENDIF - ENDIF - DO k=kts+1,kte - rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) - rhoz(k) = MAX(rhoz(k),1E-4) - rhoinv(k)=1./MAX(rho(k),1E-4) - dzk = 0.5 *( dz(k)+dz(k-1) ) - khdz(k) = rhoz(k)*dfh(k) - ENDDO - khdz(kte+1)=rhoz(kte+1)*dfh(kte) - - !stability criteria for mf - DO k=kts+1,kte-1 - khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) - khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - - khdz_old = khdz(k) - khdz_back = pblh * 0.15 / dz(k) - IF ( enh_vermix ) THEN - !Modify based on anthropogenic emissions of NO and FRP - IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > no_threshold ) THEN - khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - IF ( frp_mean > frp_threshold ) THEN - khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - ENDIF - ENDIF + !thl(k)=d(k-kts+1) + thl(k)=x(k) ENDDO - !============================================ - ! Patterned after mixing of water vapor in mynn_tendencies. - !============================================ +IF (bl_mynn_mixqt > 0) THEN + !============================================ + ! MIX total water (sqw = sqc + sqv + sqi) + ! NOTE: no total water tendency is output; instead, we must calculate + ! the saturation specific humidity and then + ! subtract out the moisture excess (sqc & sqi) + !============================================ - DO ic = 1,nchem - k=kts + k=kts - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources - & + dtz(k) * -vd1(ic)*chem1(1,ic) & - & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& +! d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) +! ENDDO - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) - ENDDO +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqw(k) + dtz(k)*rhosfc*flq*rhoinv(k) + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqt(k+1) - dtz(k)*rhoinv(k)*sd_awqt(k+1) - ! prescribed value at top - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=chem1(kte,ic) + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqw(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*rhoinv(k)*(sd_awqt(k)-sd_awqt(k+1)) + ENDDO - !CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqw(kte) - DO k=kts,kte - !chem_new(k,ic)=d(k) - chem1(k,ic)=x(k) - ENDDO - ENDDO +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,sqw2) + CALL tridiag3(kte,a,b,c,d,sqw2) - END SUBROUTINE mynn_mix_chem -#endif +! DO k=kts,kte +! sqw2(k)=d(k-kts+1) +! ENDDO +ELSE + sqw2=sqw +ENDIF -! ================================================================== -!>\ingroup gsd_mynn_edmf - SUBROUTINE retrieve_exchange_coeffs(kts,kte,& - &dfm,dfh,dz,K_m,K_h) +IF (bl_mynn_mixqt == 0) THEN +!============================================ +! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), +! then sqc will be backed out of saturation check (below). +!============================================ + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN -!------------------------------------------------------------------- + k=kts - INTEGER , INTENT(in) :: kts,kte +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - & +! dtz(k)*s_awqc(k+1) + det_sqc(k)*delt +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + & +! det_sqc(k)*delt +! ENDDO - REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqc(k) + dtz(k)*rhosfc*flqc*rhoinv(k) + qcd(k)*delt & + & - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + & + & det_sqc(k)*delt - REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqc(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*rhoinv(k)*(sd_awqc(k)-sd_awqc(k+1)) + & + & det_sqc(k)*delt + ENDDO +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqc(kte) - INTEGER :: k - REAL :: dzk +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,sqc2) + CALL tridiag3(kte,a,b,c,d,sqc2) - K_m(kts)=0. - K_h(kts)=0. +! DO k=kts,kte +! sqc2(k)=d(k-kts+1) +! ENDDO + ELSE + !If not mixing clouds, set "updated" array equal to original array + sqc2=sqc + ENDIF +ENDIF - DO k=kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - K_m(k)=dfm(k)*dzk - K_h(k)=dfh(k)*dzk - ENDDO +IF (bl_mynn_mixqt == 0) THEN + !============================================ + ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), + ! then sqv will be backed out of saturation check (below). + !============================================ - END SUBROUTINE retrieve_exchange_coeffs + k=kts -! ================================================================== -!>\ingroup gsd_mynn_edmf - SUBROUTINE tridiag(n,a,b,c,d) +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + & +! & sub_sqv(k)*delt + det_sqv(k)*delt +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + & +! & sub_sqv(k)*delt + det_sqv(k)*delt +! ENDDO -!! to solve system of linear eqs on tridiagonal matrix n times n -!! after Peaceman and Rachford, 1955 -!! a,b,c,d - are vectors of order n -!! a,b,c - are coefficients on the LHS -!! d - is initially RHS on the output becomes a solution vector - -!------------------------------------------------------------------- + !limit unreasonably large negative fluxes: + qvflux = flqv + if (qvflux < 0.0) then + !do not allow specified surface flux to reduce qv below 1e-8 kg/kg + qvflux = max(qvflux, (min(0.9*sqv(kts) - 1e-8, 0.0)/dtz(kts))) + endif - INTEGER, INTENT(in):: n - REAL, DIMENSION(n), INTENT(in) :: a,b - REAL, DIMENSION(n), INTENT(inout) :: c,d - - INTEGER :: i - REAL :: p - REAL, DIMENSION(n) :: q - - c(n)=0. - q(1)=-c(1)/b(1) - d(1)=d(1)/b(1) - - DO i=2,n - p=1./(b(i)+a(i)*q(i-1)) - q(i)=-c(i)*p - d(i)=(d(i)-a(i)*d(i-1))*p - ENDDO - - DO i=n-1,1,-1 - d(i)=d(i)+q(i)*d(i+1) +!rho-weighted: rhosfc*X*rhoinv(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqv(k) + dtz(k)*rhosfc*qvflux*rhoinv(k) + qcd(k)*delt & + & - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + & + & sub_sqv(k)*delt + det_sqv(k)*delt + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqv(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*rhoinv(k)*(sd_awqv(k)-sd_awqv(k+1)) + & + & sub_sqv(k)*delt + det_sqv(k)*delt ENDDO - END SUBROUTINE tridiag +! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. -! ================================================================== -!>\ingroup gsd_mynn_edmf - subroutine tridiag2(n,a,b,c,d,x) - implicit none -! a - sub-diagonal (means it is the diagonal below the main diagonal) -! b - the main diagonal -! c - sup-diagonal (means it is the diagonal above the main diagonal) -! d - right part -! x - the answer -! n - number of unknowns (levels) +! specified gradient at the top +! assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop - integer,intent(in) :: n - real, dimension(n),intent(in) :: a,b,c,d - real ,dimension(n),intent(out) :: x - real ,dimension(n) :: cp,dp - real :: m - integer :: i +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqv(kte) - ! initialize c-prime and d-prime - cp(1) = c(1)/b(1) - dp(1) = d(1)/b(1) - ! solve for vectors c-prime and d-prime - do i = 2,n - m = b(i)-cp(i-1)*a(i) - cp(i) = c(i)/m - dp(i) = (d(i)-dp(i-1)*a(i))/m - enddo - ! initialize x - x(n) = dp(n) - ! solve for x from the vectors c-prime and d-prime - do i = n-1, 1, -1 - x(i) = dp(i)-cp(i)*x(i+1) - end do +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,sqv2) + CALL tridiag3(kte,a,b,c,d,sqv2) - end subroutine tridiag2 -! ================================================================== -!>\ingroup gsd_mynn_edmf - subroutine tridiag3(kte,a,b,c,d,x) - -!ccccccccccccccccccccccccccccccc -! Aim: Inversion and resolution of a tridiagonal matrix -! A X = D -! Input: -! a(*) lower diagonal (Ai,i-1) -! b(*) principal diagonal (Ai,i) -! c(*) upper diagonal (Ai,i+1) -! d -! Output -! x results -!ccccccccccccccccccccccccccccccc +! DO k=kts,kte +! sqv2(k)=d(k-kts+1) +! ENDDO +ELSE + sqv2=sqv +ENDIF - implicit none - integer,intent(in) :: kte - integer, parameter :: kts=1 - real, dimension(kte) :: a,b,c,d - real ,dimension(kte),intent(out) :: x - integer :: in +!============================================ +! MIX CLOUD ICE ( sqi ) +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN -! integer kms,kme,kts,kte,in -! real a(kms:kme,3),c(kms:kme),x(kms:kme) + k=kts - do in=kte-1,kts,-1 - d(in)=d(in)-c(in)*d(in+1)/b(in+1) - b(in)=b(in)-c(in)*a(in+1)/b(in+1) - enddo +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) +! c(k)= -dtz(k)*dfh(k+1) +! d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) +! c(k)= -dtz(k)*dfh(k+1) +! d(k)=sqi(k) !+ qcd(k)*delt +! ENDDO - do in=kts+1,kte - d(in)=d(in)-a(in)*d(in-1)/b(in-1) - enddo +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqi(k) - do in=kts,kte - x(in)=d(in)/b(in) - enddo + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqi(k) + ENDDO - return - end subroutine tridiag3 -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine is the GSD MYNN-EDNF PBL driver routine,which -!! encompassed the majority of the subroutines that comprise the -!! procedures that ultimately solve for tendencies of -!! \f$U, V, \theta, q_v, q_c, and q_i\f$. -!!\section gen_mynn_bl_driver GSD mynn_bl_driver General Algorithm -!> @{ - SUBROUTINE mynn_bl_driver( & - &initflag,restart,cycling, & - &grav_settling, & - &delt,dz,dx,znt, & - &u,v,w,th,sqv3D,sqc3D,sqi3D, & - &qnc,qni, & - &qnwfa,qnifa,ozone, & - &p,exner,rho,T3D, & - &xland,ts,qsfc,qcg,ps, & - &ust,ch,hfx,qfx,rmol,wspd, & - &uoce,voce, & !ocean current - &vdfg, & !Katata-added for fog dep - &Qke, & !TKE_PBL, & - &qke_adv,bl_mynn_tkeadvect, & !ACF for QKE advection -#if (WRF_CHEM == 1) - chem3d, vd3d, nchem, & ! WA 7/29/15 For WRF-Chem - kdvel, ndvel, num_vert_mix, & - FRP_MEAN,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - mynn_chem_vertmx, & ! JLS/RAR - enh_vermix, & ! JLS/RAR -#endif - &Tsq,Qsq,Cov, & - &RUBLTEN,RVBLTEN,RTHBLTEN, & - &RQVBLTEN,RQCBLTEN,RQIBLTEN, & - &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN,DOZONE, & - &exch_h,exch_m, & - &Pblh,kpbl, & - &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & !JOE-TKE BUDGET - &wstar,delta, & !JOE-added for grims - &bl_mynn_tkebudget, & - &bl_mynn_cloudpdf,Sh3D, & - &bl_mynn_mixlength, & - &icloud_bl,qc_bl,qi_bl,cldfra_bl,& - &bl_mynn_edmf, & - &bl_mynn_edmf_mom,bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &bl_mynn_output, & - &bl_mynn_cloudmix,bl_mynn_mixqt, & - &closure, & - &edmf_a,edmf_w,edmf_qt, & - &edmf_thl,edmf_ent,edmf_qc, & - &sub_thl3D,sub_sqv3D, & - &det_thl3D,det_sqv3D, & - &nupdraft,maxMF,ktop_plume, & - &spp_pbl,pattern_spp_pbl, & - &RTHRATEN, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) - -!------------------------------------------------------------------- +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. - INTEGER, INTENT(in) :: initflag - !INPUT NAMELIST OPTIONS: - LOGICAL, INTENT(IN) :: restart,cycling - INTEGER, INTENT(in) :: grav_settling - INTEGER, INTENT(in) :: bl_mynn_tkebudget - INTEGER, INTENT(in) :: bl_mynn_cloudpdf - INTEGER, INTENT(in) :: bl_mynn_mixlength - INTEGER, INTENT(in) :: bl_mynn_edmf - LOGICAL, INTENT(in) :: bl_mynn_tkeadvect - INTEGER, INTENT(in) :: bl_mynn_edmf_mom - INTEGER, INTENT(in) :: bl_mynn_edmf_tke - INTEGER, INTENT(in) :: bl_mynn_mixscalars - INTEGER, INTENT(in) :: bl_mynn_output - INTEGER, INTENT(in) :: bl_mynn_cloudmix - INTEGER, INTENT(in) :: bl_mynn_mixqt - INTEGER, INTENT(in) :: icloud_bl - REAL, INTENT(in) :: closure +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop - LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA -#if (WRF_CHEM == 1) - LOGICAL, INTENT(IN) :: mynn_chem_vertmx,enh_vermix -#endif +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqi(kte) - INTEGER,INTENT(in) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,sqi2) + CALL tridiag3(kte,a,b,c,d,sqi2) -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif +! DO k=kts,kte +! sqi2(k)=d(k-kts+1) +! ENDDO +ELSE + sqi2=sqi +ENDIF -! initflag > 0 for TRUE -! else for FALSE -! closure : <= 2.5; Level 2.5 -! 2.5< and <3; Level 2.6 -! = 3; Level 3 -! grav_settling = 1 when gravitational settling accounted for -! grav_settling = 0 when gravitational settling NOT accounted for - - REAL, INTENT(in) :: delt -!WRF -! REAL, INTENT(in) :: dx -!END WRF -!FV3 - REAL, DIMENSION(IMS:IME), INTENT(in) :: dx -!END FV3 - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz,& - &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in)::& - &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone - REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust,& - &ch,ts,qsfc,qcg,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt +!!============================================ +!! cloud ice number concentration (qni) +!!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. & + bl_mynn_mixscalars > 0) THEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &Qke,Tsq,Qsq,Cov, & - !&tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2) - &qke_adv !ACF for QKE advection + k=kts - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qni(k) - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc + ENDDO - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & - &exch_h,exch_m +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qni(kte) - !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(:,:), OPTIONAL, INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & - & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) -! REAL, DIMENSION(IMS:IME,KMS:KME) :: & -! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd + DO k=kts,kte + !qni2(k)=d(k-kts+1) + qni2(k)=x(k) + ENDDO - REAL, DIMENSION(IMS:IME), INTENT(inout) :: Pblh,wstar,delta,rmol +ELSE + qni2=qni +ENDIF - REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu +!!============================================ +!! cloud water number concentration (qnc) +!! include non-local transport +!!============================================ + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & + bl_mynn_mixscalars > 0) THEN - INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: & - &KPBL,nupdraft,ktop_plume + k=kts - REAL, DIMENSION(IMS:IME), INTENT(OUT) :: & - &maxmf + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &el_pbl + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc + ENDDO - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & - &qWT,qSHEAR,qBUOY,qDISS,dqke - ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0. - ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnc(kte) - REAL, DIMENSION(IMS:IME,KMS:KME) :: Sh3D +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& - qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old + DO k=kts,kte + !qnc2(k)=d(k-kts+1) + qnc2(k)=x(k) + ENDDO -! WA 7/29/15 Mix chemical arrays -#if (WRF_CHEM == 1) - INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix - REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), OPTIONAL :: chem3d - REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), OPTIONAL :: vd3d - REAL, DIMENSION(ims:ime), INTENT(IN), OPTIONAL ::FRP_MEAN,EMIS_ANT_NO - - REAL, DIMENSION( kts:kte, nchem ) :: chem1 - REAL, DIMENSION( kts:kte+1, nchem ) :: s_awchem1 - REAL, DIMENSION( ndvel ) :: vd1 - INTEGER ic -#endif +ELSE + qnc2=qnc +ENDIF -!local vars - INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k - REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - &Vt, Vq, sgm, thlsg, sqwsg - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& - & qke1,tsq1,qsq1,cov1,sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & - & k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1,dozone1 +!============================================ +! Water-friendly aerosols ( qnwfa ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. & + bl_mynn_mixscalars > 0) THEN -!JOE: mass-flux variables - REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& - edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,& - edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & - det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& - s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1,& - sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 + k=kts - REAL, DIMENSION(KTS:KTE+1) :: zw - REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& - & afk,abk,ts_decay, qc_bl2, qi_bl2, & - & th_sfc,ztop_plume,sqc9,sqi9 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc -!JOE-top-down diffusion - REAL, DIMENSION(ITS:ITE) :: maxKHtopdown - REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD -!JOE-end top down + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc + ENDDO - LOGICAL :: INITIALIZE_QKE +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnwfa(kte) -! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) -! Substepping TKE - INTEGER :: nsub - real :: delt2 + DO k=kts,kte + !qnwfa2(k)=d(k) + qnwfa2(k)=x(k) + ENDDO - IF ( debug_code ) THEN - print*,'in MYNN driver; at beginning' - ENDIF +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnwfa2=qnwfa +ENDIF -!*** Begin debugging - IMD=(IMS+IME)/2 - JMD=(JMS+JME)/2 -!*** End debugging +!============================================ +! Ice-friendly aerosols ( qnifa ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars > 0) THEN -!WRF -! JTF=MIN0(JTE,JDE-1) -! ITF=MIN0(ITE,IDE-1) -! KTF=MIN0(KTE,KDE-1) -!FV3 - JTF=JTE - ITF=ITE - KTF=KTE + k=kts - IF (bl_mynn_output > 0) THEN !research mode - edmf_a(its:ite,kts:kte)=0. - edmf_w(its:ite,kts:kte)=0. - edmf_qt(its:ite,kts:kte)=0. - edmf_thl(its:ite,kts:kte)=0. - edmf_ent(its:ite,kts:kte)=0. - edmf_qc(its:ite,kts:kte)=0. - sub_thl3D(its:ite,kts:kte)=0. - sub_sqv3D(its:ite,kts:kte)=0. - det_thl3D(its:ite,kts:kte)=0. - det_sqv3D(its:ite,kts:kte)=0. + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc - !edmf_a_dd(its:ite,kts:kte)=0. - !edmf_w_dd(its:ite,kts:kte)=0. - !edmf_qt_dd(its:ite,kts:kte)=0. - !edmf_thl_dd(its:ite,kts:kte)=0. - !edmf_ent_dd(its:ite,kts:kte)=0. - !edmf_qc_dd(its:ite,kts:kte)=0. - ENDIF - ktop_plume(its:ite)=0 !int - nupdraft(its:ite)=0 !int - maxmf(its:ite)=0. - maxKHtopdown(its:ite)=0. + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc + ENDDO - ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS -!> - Within the MYNN-EDMF, there is a dependecy check for the first time step, -!! If true, a three-dimensional initialization loop is entered. Within this loop, -!! several arrays are initialized and k-oriented (vertical) subroutines are called -!! at every i and j point, corresponding to the x- and y- directions, respectively. - IF (initflag > 0 .and. .not.restart) THEN +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnifa(kte) - !Test to see if we want to initialize qke - IF ( (restart .or. cycling)) THEN - IF (MAXVAL(QKE(its:ite,kts)) < 0.0002) THEN - INITIALIZE_QKE = .TRUE. - !print*,"QKE is too small, must initialize" - ELSE - INITIALIZE_QKE = .FALSE. - !print*,"Using background QKE, will not initialize" - ENDIF - ELSE ! not cycling or restarting: - INITIALIZE_QKE = .TRUE. - !print*,"not restart nor cycling, must initialize QKE" - ENDIF - - if (.not.restart .or. .not.cycling) THEN - Sh3D(its:ite,kts:kte)=0. - el_pbl(its:ite,kts:kte)=0. - tsq(its:ite,kts:kte)=0. - qsq(its:ite,kts:kte)=0. - cov(its:ite,kts:kte)=0. - cldfra_bl(its:ite,kts:kte)=0. - qc_bl(its:ite,kts:kte)=0. - qke(its:ite,kts:kte)=0. - else - qc_bl1D(kts:kte)=0.0 - qi_bl1D(kts:kte)=0.0 - cldfra_bl1D(kts:kte)=0.0 - end if - dqc1(kts:kte)=0.0 - dqi1(kts:kte)=0.0 - dqni1(kts:kte)=0.0 - dqnc1(kts:kte)=0.0 - dqnwfa1(kts:kte)=0.0 - dqnifa1(kts:kte)=0.0 - dozone1(kts:kte)=0.0 - qc_bl1D_old(kts:kte)=0.0 - cldfra_bl1D_old(kts:kte)=0.0 - edmf_a1(kts:kte)=0.0 - edmf_w1(kts:kte)=0.0 - edmf_qc1(kts:kte)=0.0 - edmf_a_dd1(kts:kte)=0.0 - edmf_w_dd1(kts:kte)=0.0 - edmf_qc_dd1(kts:kte)=0.0 - sgm(kts:kte)=0.0 - vt(kts:kte)=0.0 - vq(kts:kte)=0.0 +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) - DO k=KTS,KTE - DO i=ITS,ITF - exch_m(i,k)=0. - exch_h(i,k)=0. - ENDDO - ENDDO + DO k=kts,kte + !qnifa2(k)=d(k-kts+1) + qnifa2(k)=x(k) + ENDDO - IF ( bl_mynn_tkebudget == 1) THEN - DO k=KTS,KTE - DO i=ITS,ITF - qWT(i,k)=0. - qSHEAR(i,k)=0. - qBUOY(i,k)=0. - qDISS(i,k)=0. - dqke(i,k)=0. - ENDDO - ENDDO - ENDIF +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnifa2=qnifa +ENDIF - DO i=ITS,ITF - DO k=KTS,KTE !KTF - dz1(k)=dz(i,k) - u1(k) = u(i,k) - v1(k) = v(i,k) - w1(k) = w(i,k) - th1(k)=th(i,k) - tk1(k)=T3D(i,k) - ex1(k)=exner(i,k) - rho1(k)=rho(i,k) - sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) - sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) - thetav(k)=th(i,k)*(1.+0.608*sqv(k)) - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - ENDIF - IF (PRESENT(sqi3D) .AND. FLAG_QI ) THEN - sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) - sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - sqi(k)=0.0 - sqw(k)=sqv(k)+sqc(k) - thl(k)=th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=0.0 - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ENDIF - thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) +!============================================ +! Ozone - local mixing only +!============================================ - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1) - ENDIF - IF (INITIALIZE_QKE) THEN - !Initialize tke for initial PBLH calc only - using - !simple PBLH form of Koracin and Berkowicz (1988, BLM) - !to linearly taper off tke towards top of PBL. - qke1(k)=5.*ust(i) * MAX((ust(i)*700. - zw(k))/(MAX(ust(i),0.01)*700.), 0.01) - ELSE - qke1(k)=qke(i,k) - ENDIF - el(k)=el_pbl(i,k) - sh(k)=Sh3D(i,k) - tsq1(k)=tsq(i,k) - qsq1(k)=qsq(i,k) - cov1(k)=cov(i,k) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k) - else - rstoch_col(k)=0.0 - endif + k=kts + +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=ozone(k) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=ozone(k) + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=ozone(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !ozone2(k)=d(k-kts+1) + dozone(k)=(x(k)-ozone(k))/delt + ENDDO + +!!============================================ +!! Compute tendencies and convert to mixing ratios for WRF. +!! Note that the momentum tendencies are calculated above. +!!============================================ + + IF (bl_mynn_mixqt > 0) THEN + DO k=kts,kte + !compute updated theta using updated thl and old condensate + th_new = thl(k) + xlvcp/exner(k)*sqc(k) & + & + xlscp/exner(k)*sqi(k) + + t = th_new*exner(k) + qsat = qsat_blend(t,p(k)) + !SATURATED VAPOR PRESSURE + !esat=esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + + IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated + sqv2(k) = MIN(sqw2(k),qsat) + portion_qc = sqc(k)/(sqc(k) + sqi(k)) + portion_qi = sqi(k)/(sqc(k) + sqi(k)) + condensate = MAX(sqw2(k) - qsat, 0.0) + sqc2(k) = condensate*portion_qc + sqi2(k) = condensate*portion_qi + ELSE ! initially unsaturated ----- + sqv2(k) = sqw2(k) ! let microphys decide what to do + sqi2(k) = 0.0 ! if sqw2 > qsat + sqc2(k) = 0.0 + ENDIF + !dqv(k) = (sqv2(k) - sqv(k))/delt + !dqc(k) = (sqc2(k) - sqc(k))/delt + !dqi(k) = (sqi2(k) - sqi(k))/delt + ENDDO + ENDIF + + + !===================== + ! WATER VAPOR TENDENCY + !===================== + DO k=kts,kte + Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k + ENDDO + + IF (bl_mynn_cloudmix > 0) THEN + !===================== + ! CLOUD WATER TENDENCY + !===================== + !print*,"FLAG_QC:",FLAG_QC + IF (FLAG_QC) THEN + DO k=kts,kte + Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt + !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k + ENDDO + ELSE + DO k=kts,kte + Dqc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD WATER NUM CONC TENDENCY + !=================== + IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + Dqnc(k) = (qnc2(k)-qnc(k))/delt + !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqnc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt + !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k + ENDDO + ELSE + DO k=kts,kte + Dqi(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE NUM CONC TENDENCY + !=================== + IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + Dqni(k)=(qni2(k)-qni(k))/delt + !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqni(k)=0. + ENDDO + ENDIF + ELSE !-MIX CLOUD SPECIES? + !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) + DO k=kts,kte + Dqc(k)=0. + Dqnc(k)=0. + Dqi(k)=0. + Dqni(k)=0. + ENDDO + ENDIF + + !ensure non-negative moist species + CALL moisture_check(kte, delt, delp, exner, & + sqv2, sqc2, sqi2, thl, & + dqv, dqc, dqi, dth ) + + !===================== + ! OZONE TENDENCY CHECK + !===================== + DO k=kts,kte + IF(Dozone(k)*delt + ozone(k) < 0.) THEN + Dozone(k)=-ozone(k)*0.99/delt + ENDIF + ENDDO + + !=================== + ! THETA TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & + & + xlscp/exner(k)*sqi2(k) & + & - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy: + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k) & + ! & + xlscp/MAX(tk(k),TKmin)*sqi(k)) & + ! & - th(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)) & + !& - th(k))/delt + ENDDO + ENDIF - ENDDO + !=================== + ! AEROSOL TENDENCIES + !=================== + IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + !===================== + ! WATER-friendly aerosols + !===================== + Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt + !===================== + ! Ice-friendly aerosols + !===================== + Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqnwfa(k)=0. + Dqnifa(k)=0. + ENDDO + ENDIF - zw(kte+1)=zw(kte)+dz(i,kte) + !ensure non-negative moist species + !note: if called down here, dth needs to be updated, but + ! if called before the theta-tendency calculation, do not compute dth + !CALL moisture_check(kte, delt, delp, exner, & + ! sqv, sqc, sqi, thl, & + ! dqv, dqc, dqi, dth ) -!> - Call get_pblh() to calculate hybrid (\f$\theta_{vli}-TKE\f$) PBL height. -! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i),thvl, & - & Qke1,zw,dz1,xland(i),KPBL(i)) - -!> - Call scale_aware() to calculate similarity functions for scale-adaptive control -!! (\f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$). - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) - ELSE - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - ENDIF + problem = .false. + do k=kts,kte + wsp = sqrt(u(k)**2 + v(k)**2) + wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) + if (wsp2 > 200.) then + problem = .true. + print*,"Problem: i=",i," k=",k," wsp=",wsp2 + print*," du=",du(k)*delt," dv=",dv(k)*delt + print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) + print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(k) + kproblem = k + endif + enddo + if (problem) then + print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) + endif - ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS -!> - Call mym_initialize() to initializes the mixing length, TKE, \f$\theta^{'2}\f$, -!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. These variables are calculated after -!! obtaining prerequisite variables by calling the following subroutines from -!! within mym_initialize(): mym_level2() and mym_length(). - CALL mym_initialize ( & - &kts,kte, & - &dz1, dx(i), zw, & - &u1, v1, thl, sqv, & - &thlsg, sqwsg, & - &PBLH(i), th1, thetav, sh, sm, & - &ust(i), rmol(i), & - &el, Qke1, Tsq1, Qsq1, Cov1, & - &Psig_bl(i), cldfra_bl1D, & - &bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& - &INITIALIZE_QKE, & - &spp_pbl,rstoch_col ) +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif - IF (.not.restart) THEN - !UPDATE 3D VARIABLES - DO k=KTS,KTE !KTF - el_pbl(i,k)=el(k) - sh3d(i,k)=sh(k) - qke(i,k)=qke1(k) - tsq(i,k)=tsq1(k) - qsq(i,k)=qsq1(k) - cov(i,k)=cov1(k) - ENDDO - !initialize qke_adv array if using advection - IF (bl_mynn_tkeadvect) THEN - DO k=KTS,KTE - qke_adv(i,k)=qke1(k) - ENDDO - ENDIF - ENDIF + END SUBROUTINE mynn_tendencies -!*** Begin debugging -! k=kdebug -! IF(I==IMD .AND. J==JMD)THEN -! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k) -! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) -! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",Tsq(i,k) -! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) -! ENDIF -!*** End debugging +! ================================================================== + SUBROUTINE moisture_check(kte, delt, dp, exner, & + qv, qc, qi, th, & + dqv, dqc, dqi, dth ) - ENDDO !end i-loop + ! This subroutine was adopted from the CAM-UW ShCu scheme and + ! adapted for use here. + ! + ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, + ! force them to be larger than minimum value by (1) condensating + ! water vapor into liquid or ice, and (2) by transporting water vapor + ! from the very lower layer. + ! + ! We then update the final state variables and tendencies associated + ! with this correction. If any condensation happens, update theta too. + ! Note that (qv,qc,qi,th) are the final state variables after + ! applying corresponding input tendencies and corrective tendencies. - ENDIF ! end initflag + implicit none + integer, intent(in) :: kte + real, intent(in) :: delt + real, dimension(kte), intent(in) :: dp, exner + real, dimension(kte), intent(inout) :: qv, qc, qi, th + real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth + integer k + real :: dqc2, dqi2, dqv2, sum, aa, dum + real, parameter :: qvmin = 1e-20, & + qcmin = 0.0, & + qimin = 0.0 -!> - After initializing all required variables, the regular procedures -!! performed at every time step are ready for execution. - !ACF- copy qke_adv array into qke if using advection - IF (bl_mynn_tkeadvect) THEN - qke=qke_adv - ENDIF + do k = kte, 1, -1 ! From the top to the surface + dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) + dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) - DO i=ITS,ITF - DO k=KTS,KTE !KTF - !JOE-TKE BUDGET - IF ( bl_mynn_tkebudget == 1) THEN - dqke(i,k)=qke(i,k) - END IF - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - cldfra_bl1D_old(k)=cldfra_bl(i,k) - qc_bl1D_old(k)=qc_bl(i,k) - qi_bl1D_old(k)=qi_bl(i,k) - else - CLDFRA_BL1D(k)=0.0 - QC_BL1D(k)=0.0 - QI_BL1D(k)=0.0 - cldfra_bl1D_old(k)=0.0 - qc_bl1D_old(k)=0.0 - qi_bl1D_old(k)=0.0 - ENDIF - dz1(k)= dz(i,k) - u1(k) = u(i,k) - v1(k) = v(i,k) - w1(k) = w(i,k) - th1(k)= th(i,k) - tk1(k)=T3D(i,k) - p1(k) = p(i,k) - ex1(k)= exner(i,k) - rho1(k)=rho(i,k) - qv1(k)= sqv3D(i,k)/(1.-sqv3D(i,k)) - qc1(k)= sqc3D(i,k)/(1.-sqv3D(i,k)) - sqv(k)= sqv3D(i,k) !/(1.+qv(i,k)) - sqc(k)= sqc3D(i,k) !/(1.+qv(i,k)) - dqc1(k)=0.0 - dqi1(k)=0.0 - dqni1(k)=0.0 - dqnc1(k)=0.0 - dqnwfa1(k)=0.0 - dqnifa1(k)=0.0 - dozone1(k)=0.0 - IF(PRESENT(sqi3D) .AND. FLAG_QI)THEN - qi1(k)= sqi3D(i,k)/(1.-sqv3D(i,k)) - sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) - sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - qi1(k)=0.0 - sqi(k)=0.0 - sqw(k)= sqv(k)+sqc(k) - thl(k)= th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - ENDIF - thetav(k)=th1(k)*(1.+0.608*sqv(k)) - thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) + !fix tendencies + dqc(k) = dqc(k) + dqc2/delt + dqi(k) = dqi(k) + dqi2/delt + dqv(k) = dqv(k) - (dqc2+dqi2)/delt + dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & + xlscp/exner(k)*(dqi2/delt) + !update species + qc(k) = qc(k) + dqc2 + qi(k) = qi(k) + dqi2 + qv(k) = qv(k) - dqc2 - dqi2 + th(k) = th(k) + xlvcp/exner(k)*dqc2 + & + xlscp/exner(k)*dqi2 + + !then fix qv + dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) + dqv(k) = dqv(k) + dqv2/delt + qv(k) = qv(k) + dqv2 + if( k .ne. 1 ) then + qv(k-1) = qv(k-1) - dqv2*dp(k)/dp(k-1) + dqv(k-1) = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt + endif + qv(k) = max(qv(k),qvmin) + qc(k) = max(qc(k),qcmin) + qi(k) = max(qi(k),qimin) + end do + ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv2 .gt. 1.e-20 ) then + sum = 0.0 + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) + enddo + aa = dqv2*dp(1)/max(1.e-20,sum) + if( aa .lt. 0.5 ) then + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) then + dum = aa*qv(k) + qv(k) = qv(k) - dum + dqv(k) = dqv(k) - dum/delt + endif + enddo + else + ! For testing purposes only (not yet found in any output): + ! write(*,*) 'Full moisture conservation is impossible' + endif + endif - IF (PRESENT(qni) .AND. FLAG_QNI ) THEN - qni1(k)=qni(i,k) - ELSE - qni1(k)=0.0 - ENDIF - IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN - qnc1(k)=qnc(i,k) - ELSE - qnc1(k)=0.0 - ENDIF - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN - qnwfa1(k)=qnwfa(i,k) - ELSE - qnwfa1(k)=0.0 - ENDIF - IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN - qnifa1(k)=qnifa(i,k) - ELSE - qnifa1(k)=0.0 - ENDIF - IF (PRESENT(ozone)) THEN - ozone1(k)=ozone(i,k) - ELSE - ozone1(k)=0.0 - ENDIF - el(k) = el_pbl(i,k) - qke1(k)=qke(i,k) - sh(k) = sh3d(i,k) - tsq1(k)=tsq(i,k) - qsq1(k)=qsq(i,k) - cov1(k)=cov(i,k) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k) - else - rstoch_col(k)=0.0 - endif + return - !edmf - edmf_a1(k)=0.0 - edmf_w1(k)=0.0 - edmf_qc1(k)=0.0 - s_aw1(k)=0. - s_awthl1(k)=0. - s_awqt1(k)=0. - s_awqv1(k)=0. - s_awqc1(k)=0. - s_awu1(k)=0. - s_awv1(k)=0. - s_awqke1(k)=0. - s_awqnc1(k)=0. - s_awqni1(k)=0. - s_awqnwfa1(k)=0. - s_awqnifa1(k)=0. - ![EWDD] - edmf_a_dd1(k)=0.0 - edmf_w_dd1(k)=0.0 - edmf_qc_dd1(k)=0.0 - sd_aw1(k)=0. - sd_awthl1(k)=0. - sd_awqt1(k)=0. - sd_awqv1(k)=0. - sd_awqc1(k)=0. - sd_awu1(k)=0. - sd_awv1(k)=0. - sd_awqke1(k)=0. - sub_thl(k)=0. - sub_sqv(k)=0. - sub_u(k)=0. - sub_v(k)=0. - det_thl(k)=0. - det_sqv(k)=0. - det_sqc(k)=0. - det_u(k)=0. - det_v(k)=0. + END SUBROUTINE moisture_check -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - IF (PRESENT(chem3d) .AND. PRESENT(vd3d)) THEN - ! WA 7/29/15 Set up chemical arrays - DO ic = 1,nchem - chem1(k,ic) = chem3d(i,k,ic) - s_awchem1(k,ic)=0. - ENDDO - DO ic = 1,ndvel - IF (k == KTS) THEN - vd1(ic) = vd3d(i,1,ic) - ENDIF - ENDDO - ELSE - DO ic = 1,nchem - chem1(k,ic) = 0. - s_awchem1(k,ic)=0. - ENDDO - DO ic = 1,ndvel - IF (k == KTS) THEN - vd1(ic) = 0. - ENDIF - ENDDO - ENDIF - ENDIF -#endif +! ================================================================== - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1) - ENDIF - ENDDO ! end k + SUBROUTINE mynn_mix_chem(kts,kte,i, & + delt,dz,pblh, & + nchem, kdvel, ndvel, & + chem1, vd1, & + rho, & + flt, tcd, qcd, & + dfh, & + s_aw, s_awchem, & + emis_ant_no,frp, & + fire_turb ) - zw(kte+1)=zw(kte)+dz(i,kte) - !EDMF - s_aw1(kte+1)=0. - s_awthl1(kte+1)=0. - s_awqt1(kte+1)=0. - s_awqv1(kte+1)=0. - s_awqc1(kte+1)=0. - s_awu1(kte+1)=0. - s_awv1(kte+1)=0. - s_awqke1(kte+1)=0. - s_awqnc1(kte+1)=0. - s_awqni1(kte+1)=0. - s_awqnwfa1(kte+1)=0. - s_awqnifa1(kte+1)=0. - sd_aw1(kte+1)=0. - sd_awthl1(kte+1)=0. - sd_awqt1(kte+1)=0. - sd_awqv1(kte+1)=0. - sd_awqc1(kte+1)=0. - sd_awu1(kte+1)=0. - sd_awv1(kte+1)=0. - sd_awqke1(kte+1)=0. -#if (WRF_CHEM == 1) - DO ic = 1,nchem - s_awchem1(kte+1,ic)=0. - ENDDO -#endif +!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kts,kte,i -!> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ -!! PBL height diagnostic. -! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i),thvl,& - & Qke1,zw,dz1,xland(i),KPBL(i)) + REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho + REAL, INTENT(IN) :: delt,flt + INTEGER, INTENT(IN) :: nchem, kdvel, ndvel + REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw + REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 + REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem + REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 + REAL, INTENT(IN) :: emis_ant_no,frp,pblh + LOGICAL, INTENT(IN) :: fire_turb +!local vars -!> - Call scale_aware() to calculate the similarity functions, -!! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control -!! the scale-adaptive behaviour for the local and nonlocal -!! components, respectively. - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) - ELSE - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 + REAL, DIMENSION(kts:kte) :: dtz + REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d,x + REAL :: rhs,dztop + REAL :: t,dzk + REAL :: hght + REAL :: khdz_old, khdz_back + INTEGER :: k,kk,kmaxfire ! JLS 12/21/21 + INTEGER :: ic ! Chemical array loop index + + INTEGER, SAVE :: icall + + REAL, DIMENSION(kts:kte) :: rhoinv + REAL, DIMENSION(kts:kte+1) :: rhoz,khdz + REAL, PARAMETER :: no_threshold = 0.1 + REAL, PARAMETER :: frp_threshold = 1.0 ! JLS 12/21/21 + REAL, PARAMETER :: pblh_threshold = 250.0 + + dztop=.5*(dz(kte)+dz(kte-1)) + + DO k=kts,kte + dtz(k)=delt/dz(k) + ENDDO + + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz = rho*dfh + rhoz(kts) =rho(kts) + rhoinv(kts)=1./rho(kts) + khdz(kts) =rhoz(kts)*dfh(kts) + DO k=kts+1,kte + rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + rhoz(k) = MAX(rhoz(k),1E-4) + rhoinv(k)=1./MAX(rho(k),1E-4) + dzk = 0.5 *( dz(k)+dz(k-1) ) + khdz(k) = rhoz(k)*dfh(k) + ENDDO + rhoz(kte+1)=rhoz(kte) + khdz(kte+1)=rhoz(kte+1)*dfh(kte) + + !stability criteria for mf + DO k=kts+1,kte-1 + khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) + khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + ENDDO + + !Enhance diffusion over fires + IF ( fire_turb ) THEN + DO k=kts+1,kte-1 + khdz_old = khdz(k) + khdz_back = pblh * 0.15 / dz(k) + !Modify based on anthropogenic emissions of NO and FRP + IF ( pblh < pblh_threshold ) THEN + IF ( emis_ant_no > no_threshold ) THEN + khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / no_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 +! khdz(k) = MAX(khdz(k),khdz_back) + ENDIF + IF ( frp > frp_threshold ) THEN + khdz(k) = MAX(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21 +! khdz(k) = MAX(khdz(k),khdz_back) + ENDIF ENDIF + ENDDO + ENDIF - sqcg= 0.0 !JOE, it was: qcg(i)/(1.+qcg(i)) - cpm=cp*(1.+0.84*qv1(kts)) - exnerg=(ps(i)/p1000mb)**rcp + !============================================ + ! Patterned after mixing of water vapor in mynn_tendencies. + !============================================ - !----------------------------------------------------- - !ORIGINAL CODE - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! -ch(i)*(sqc(kts) -sqcg ) - !----------------------------------------------------- - ! Katata-added - The deposition velocity of cloud (fog) - ! water is used instead of CH. - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! & +xlvcp*vdfg(i)*(sqc(kts)/exner(i,kts)- sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! & -vdfg(i)*(sqc(kts) - sqcg ) - !----------------------------------------------------- - flqv = qfx(i)/rho1(kts) - flqc = -vdfg(i)*(sqc(kts) - sqcg ) - th_sfc = ts(i)/ex1(kts) + DO ic = 1,nchem + k=kts - ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS - flq =flqv+flqc !! LATENT - flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux - fltv=flt + flqv*ep_1*th_sfc !! Virtual temperature flux + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources + & + dtz(k) * -vd1(ic)*chem1(1,ic) & + & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) - ! Update 1/L using updated sfc heat flux and friction velocity - rmol(i) = -vk*gtr*fltv/max(ust(i)**3,1.0e-6) - zet = 0.5*dz(i,kts)*rmol(i) - zet = MAX(zet, -20.) - zet = MIN(zet, 20.) - if (bl_mynn_stfunc == 0) then - !Original Kansas-type stability functions - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet - else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) - end if - else - !Updated stability functions (Puhales, 2020) - phi_m = phim(zet) - pmz = phi_m - zet - phh = phih(zet) - end if + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + ENDDO + + ! prescribed value at top + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=chem1(kte,ic) -!> - Call mym_condensation() to calculate the nonconvective component -!! of the subgrid cloud fraction and mixing ratio as well as the functions -!! used to calculate the buoyancy flux. Different cloud PDFs can be -!! selected by use of the namelist parameter \p bl_mynn_cloudpdf. + !CALL tridiag(kte,a,b,c,d) + CALL tridiag3(kte,a,b,c,d,x) - CALL mym_condensation ( kts,kte, & - &dx(i),dz1,zw,thl,sqw,sqv,sqc,sqi,& - &p1,ex1,tsq1,qsq1,cov1, & - &Sh,el,bl_mynn_cloudpdf, & - &qc_bl1D,qi_bl1D,cldfra_bl1D, & - &PBLH(i),HFX(i), & - &Vt, Vq, th1, sgm, rmol(i), & - &spp_pbl, rstoch_col ) + DO k=kts,kte + !chem_new(k,ic)=d(k) + chem1(k,ic)=x(k) + ENDDO + ENDDO -!> - Add TKE source driven by cloud top cooling -!! Calculate the buoyancy production of TKE from cloud-top cooling when -!! \p bl_mynn_topdown =1. - IF (bl_mynn_topdown.eq.1)then - CALL topdown_cloudrad(kts,kte,dz1,zw, & - &xland(i),kpbl(i),PBLH(i), & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten, & - &maxKHtopdown(i),KHtopdown,TKEprodTD ) - ELSE - maxKHtopdown(i) = 0.0 - KHtopdown(kts:kte) = 0.0 - TKEprodTD(kts:kte) = 0.0 - ENDIF + END SUBROUTINE mynn_mix_chem - IF (bl_mynn_edmf > 0) THEN - !PRINT*,"Calling DMP Mass-Flux: i= ",i - CALL DMP_mf( & - &kts,kte,delt,zw,dz1,p1,rho1, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &u1,v1,w1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,qke1, & - &qnc1,qni1,qnwfa1,qnifa1, & - &ex1,Vt,Vq,sgm, & - &ust(i),flt,flq,flqv,flqc, & - &PBLH(i),KPBL(i),DX(i), & - &xland(i),th_sfc, & - ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & - ! outputs - updraft properties - & edmf_a1,edmf_w1,edmf_qt1, & - & edmf_thl1,edmf_ent1,edmf_qc1, & - ! for the solver - & s_aw1,s_awthl1,s_awqt1, & - & s_awqv1,s_awqc1, & - & s_awu1,s_awv1,s_awqke1, & - & s_awqnc1,s_awqni1, & - & s_awqnwfa1,s_awqnifa1, & - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & -#if (WRF_CHEM == 1) - & nchem,chem1,s_awchem1, & - & mynn_chem_vertmx, & -#endif - & qc_bl1D,cldfra_bl1D, & - & qc_bl1D_old,cldfra_bl1D_old, & - & FLAG_QC,FLAG_QI, & - & FLAG_QNC,FLAG_QNI, & - & FLAG_QNWFA,FLAG_QNIFA, & - & Psig_shcu(i), & - & nupdraft(i),ktop_plume(i), & - & maxmf(i),ztop_plume, & - & spp_pbl,rstoch_col ) - ENDIF +! ================================================================== +!>\ingroup gsd_mynn_edmf + SUBROUTINE retrieve_exchange_coeffs(kts,kte,& + &dfm,dfh,dz,K_m,K_h) - IF (bl_mynn_edmf_dd == 1) THEN - CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, & - &u1,v1,th1,thl,thetav,tk1, & - sqw,sqv,sqc,rho1,ex1, & - &ust(i),flt,flq, & - &PBLH(i),KPBL(i), & - &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & - &edmf_thl_dd1,edmf_ent_dd1, & - &edmf_qc_dd1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & - &sd_awqke1, & - &qc_bl1d,cldfra_bl1d, & - &rthraten(i,:) ) - ENDIF +!------------------------------------------------------------------- - !Capability to substep the eddy-diffusivity portion - !do nsub = 1,2 - delt2 = delt !*0.5 !only works if topdown=0 + INTEGER , INTENT(in) :: kts,kte - CALL mym_turbulence ( & - &kts,kte,closure, & - &dz1, DX(i), zw, & - &u1, v1, thl, thetav, sqc, sqw, & - &thlsg, sqwsg, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq, & - &rmol(i), flt, flq, & - &PBLH(i),th1, & - &Sh,Sm,el, & - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc, & - &qWT1,qSHEAR1,qBUOY1,qDISS1, & - &bl_mynn_tkebudget, & - &Psig_bl(i),Psig_shcu(i), & - &cldfra_bl1D,bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - &TKEprodTD, & - &spp_pbl,rstoch_col) + REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh -!> - Call mym_predict() to solve TKE and -!! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ -!! for the following time step. - CALL mym_predict (kts,kte,closure, & - &delt2, dz1, & - &ust(i), flt, flq, pmz, phh, & - &el, dfq, rho1, pdk, pdt, pdq, pdc,& - &Qke1, Tsq1, Qsq1, Cov1, & - &s_aw1, s_awqke1, bl_mynn_edmf_tke,& - &qWT1, qDISS1,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) + REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h - DO k=kts,kte-1 - ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(0.75*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) - ENDDO - diss_heat(kte) = 0. -!> - Call mynn_tendencies() to solve for tendencies of -!! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. - CALL mynn_tendencies(kts,kte, & - &closure,grav_settling, & - &delt, dz1, rho1, & - &u1, v1, th1, tk1, qv1, & - &qc1, qi1, qnc1, qni1, & - &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, sqw, & - &qnwfa1, qnifa1, ozone1, & - &ust(i),flt,flq,flqv,flqc, & - &wspd(i),qcg(i), & - &uoce(i),voce(i), & - &tsq1, qsq1, cov1, & - &tcd, qcd, & - &dfm, dfh, dfq, & - &Du1, Dv1, Dth1, Dqv1, & - &Dqc1, Dqi1, Dqnc1, Dqni1, & - &Dqnwfa1, Dqnifa1, Dozone1, & - &vdfg(i), diss_heat, & - ! mass flux components - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,& - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) + INTEGER :: k + REAL :: dzk -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - CALL mynn_mix_chem(kts,kte,i, & - grav_settling, & - delt, dz1, pblh(i), & - nchem, kdvel, ndvel, num_vert_mix,& - chem1, vd1, & - qnc1,qni1, & - p1, ex1, thl, sqv, sqc, sqi, sqw, & - rho1, ust(i),flt,flq,flqv,flqc, & - wspd(i),qcg(i), & - tcd, qcd, & - &dfm, dfh, dfq, & - ! mass flux components - & s_aw1, & - & s_awchem1, & - &bl_mynn_cloudmix, & - EMIS_ANT_NO(i), & - FRP_MEAN(i), & - enh_vermix) - IF (PRESENT(chem3d) ) THEN - DO ic = 1,nchem - DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) - ENDDO - ENDDO - ENDIF - ENDIF -#endif + K_m(kts)=0. + K_h(kts)=0. - - CALL retrieve_exchange_coeffs(kts,kte,& - &dfm, dfh, dz1, K_m1, K_h1) + DO k=kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + K_m(k)=dfm(k)*dzk + K_h(k)=dfh(k)*dzk + ENDDO - !UPDATE 3D ARRAYS - DO k=KTS,KTE !KTF - exch_m(i,k)=K_m1(k) - exch_h(i,k)=K_h1(k) - RUBLTEN(i,k)=du1(k) - RVBLTEN(i,k)=dv1(k) - RTHBLTEN(i,k)=dth1(k) - RQVBLTEN(i,k)=dqv1(k) - IF(bl_mynn_cloudmix > 0)THEN - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=dqc1(k) - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=dqi1(k) - ELSE - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=0. - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=0. - ENDIF - IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) - ELSE - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=0. - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=0. - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=0. - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=0. - ENDIF - DOZONE(i,k)=DOZONE1(k) + END SUBROUTINE retrieve_exchange_coeffs - IF(icloud_bl > 0)THEN - !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS - IF (CLDFRA_BL1D(k) < cldfra_bl1D_old(k)) THEN - !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER - !TIMESCALE, BUT FOR WINDY CONDITIONS, IT IS THE ADVECTIVE - !TIMESCALE. USE THE MINIMUM OF THE TWO. - ts_decay = MIN( 1800., 3.*dx(i)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) - cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.20*delt/ts_decay)) - ! qc_bl2 and qi_bl2 are linked to decay rates - qc_bl2 = MAX(qc_bl1D(k),qc_bl1D_old(k)) - qi_bl2 = MAX(qi_bl1D(k),qi_bl1D_old(k)) - qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-5) * delt/ts_decay)) - qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-6) * delt/ts_decay)) - IF (cldfra_bl(i,k) < 0.005 .OR. & - (qc_bl(i,k) + qi_bl(i,k)) < 1E-9) THEN - CLDFRA_BL(i,k)= 0. - QC_BL(i,k) = 0. - QI_BL(i,k) = 0. - ENDIF - ELSE - qc_bl(i,k)=qc_bl1D(k) - qi_bl(i,k)=qi_bl1D(k) - cldfra_bl(i,k)=cldfra_bl1D(k) - ENDIF - ENDIF +! ================================================================== +!>\ingroup gsd_mynn_edmf + SUBROUTINE tridiag(n,a,b,c,d) + +!! to solve system of linear eqs on tridiagonal matrix n times n +!! after Peaceman and Rachford, 1955 +!! a,b,c,d - are vectors of order n +!! a,b,c - are coefficients on the LHS +!! d - is initially RHS on the output becomes a solution vector + +!------------------------------------------------------------------- + + INTEGER, INTENT(in):: n + REAL, DIMENSION(n), INTENT(in) :: a,b + REAL, DIMENSION(n), INTENT(inout) :: c,d + + INTEGER :: i + REAL :: p + REAL, DIMENSION(n) :: q + + c(n)=0. + q(1)=-c(1)/b(1) + d(1)=d(1)/b(1) + + DO i=2,n + p=1./(b(i)+a(i)*q(i-1)) + q(i)=-c(i)*p + d(i)=(d(i)-a(i)*d(i-1))*p + ENDDO + + DO i=n-1,1,-1 + d(i)=d(i)+q(i)*d(i+1) + ENDDO - el_pbl(i,k)=el(k) - qke(i,k)=qke1(k) - tsq(i,k)=tsq1(k) - qsq(i,k)=qsq1(k) - cov(i,k)=cov1(k) - sh3d(i,k)=sh(k) + END SUBROUTINE tridiag - ENDDO !end-k +! ================================================================== +!>\ingroup gsd_mynn_edmf + subroutine tridiag2(n,a,b,c,d,x) + implicit none +! a - sub-diagonal (means it is the diagonal below the main diagonal) +! b - the main diagonal +! c - sup-diagonal (means it is the diagonal above the main diagonal) +! d - right part +! x - the answer +! n - number of unknowns (levels) - IF ( bl_mynn_tkebudget == 1) THEN - !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) - !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) - k=kts - qSHEAR1(k)=4.*(ust(i)**3*phi_m/(vk*dz(i,k)))-qSHEAR1(k+1) !! staggered - qBUOY1(k)=4.*(-ust(i)**3*zet/(vk*dz(i,k)))-qBUOY1(k+1) !! staggered - !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array - DO k = kts,kte-1 - qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z - qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z - qWT(i,k)=qWT1(k) - qDISS(i,k)=qDISS1(k) - dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt - ENDDO - !! Upper boundary conditions - k=kte - qSHEAR(i,k)=0. - qBUOY(i,k)=0. - qWT(i,k)=0. - qDISS(i,k)=0. - dqke(i,k)=0. - ENDIF + integer,intent(in) :: n + real, dimension(n),intent(in) :: a,b,c,d + real ,dimension(n),intent(out) :: x + real ,dimension(n) :: cp,dp + real :: m + integer :: i - !update updraft/downdraft properties - if (bl_mynn_output > 0) THEN !research mode == 1 - if (bl_mynn_edmf > 0) THEN - DO k = kts,kte - edmf_a(i,k)=edmf_a1(k) - edmf_w(i,k)=edmf_w1(k) - edmf_qt(i,k)=edmf_qt1(k) - edmf_thl(i,k)=edmf_thl1(k) - edmf_ent(i,k)=edmf_ent1(k) - edmf_qc(i,k)=edmf_qc1(k) - sub_thl3D(i,k)=sub_thl(k) - sub_sqv3D(i,k)=sub_sqv(k) - det_thl3D(i,k)=det_thl(k) - det_sqv3D(i,k)=det_sqv(k) - ENDDO - endif -! if (bl_mynn_edmf_dd > 0) THEN -! DO k = kts,kte -! edmf_a_dd(i,k)=edmf_a_dd1(k) -! edmf_w_dd(i,k)=edmf_w_dd1(k) -! edmf_qt_dd(i,k)=edmf_qt_dd1(k) -! edmf_thl_dd(i,k)=edmf_thl_dd1(k) -! edmf_ent_dd(i,k)=edmf_ent_dd1(k) -! edmf_qc_dd(i,k)=edmf_qc_dd1(k) -! ENDDO -! ENDIF - ENDIF + ! initialize c-prime and d-prime + cp(1) = c(1)/b(1) + dp(1) = d(1)/b(1) + ! solve for vectors c-prime and d-prime + do i = 2,n + m = b(i)-cp(i-1)*a(i) + cp(i) = c(i)/m + dp(i) = (d(i)-dp(i-1)*a(i))/m + enddo + ! initialize x + x(n) = dp(n) + ! solve for x from the vectors c-prime and d-prime + do i = n-1, 1, -1 + x(i) = dp(i)-cp(i)*x(i+1) + end do - !*** Begin debug prints - IF ( debug_code ) THEN - DO k = kts,kte - IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) - IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) - IF ( ABS(vt(k)) > 0.8 )print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 6000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) - IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) - IF ( vdfg(i) < 0. .OR. vdfg(i)>5. )print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vdfg=",vdfg(i) - IF ( ABS(QFX(i))>.001)print*,& - "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) - IF ( ABS(HFX(i))>1000.)print*,& - "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) - IF (icloud_bl > 0) then - IF( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN - PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) - ENDIF - ENDIF + end subroutine tridiag2 +! ================================================================== +!>\ingroup gsd_mynn_edmf + subroutine tridiag3(kte,a,b,c,d,x) - !IF (I==IMD .AND. J==JMD) THEN - ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) - ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) - ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) - ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) - ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) - ! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i) - !ENDIF - ENDDO !end-k - ENDIF - !*** End debug prints +!ccccccccccccccccccccccccccccccc +! Aim: Inversion and resolution of a tridiagonal matrix +! A X = D +! Input: +! a(*) lower diagonal (Ai,i-1) +! b(*) principal diagonal (Ai,i) +! c(*) upper diagonal (Ai,i+1) +! d +! Output +! x results +!ccccccccccccccccccccccccccccccc - !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) - ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. - !tke_pbl(i,kts) = 0.5*MAX(qke(i,kts),1.0e-10) - !DO k = kts+1,kte - ! afk = dz1(k)/( dz1(k)+dz1(k-1) ) - ! abk = 1.0 -afk - ! tke_pbl(i,k) = 0.5*MAX(qke(i,k)*abk+qke(i,k-1)*afk,1.0e-3) - !ENDDO + implicit none + integer,intent(in) :: kte + integer, parameter :: kts=1 + real, dimension(kte) :: a,b,c,d + real ,dimension(kte),intent(out) :: x + integer :: in - ENDDO !end i-loop +! integer kms,kme,kts,kte,in +! real a(kms:kme,3),c(kms:kme),x(kms:kme) -!ACF copy qke into qke_adv if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv=qke - ENDIF -!ACF-end + do in=kte-1,kts,-1 + d(in)=d(in)-c(in)*d(in+1)/b(in+1) + b(in)=b(in)-c(in)*a(in+1)/b(in+1) + enddo -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif + do in=kts+1,kte + d(in)=d(in)-a(in)*d(in-1)/b(in-1) + enddo - END SUBROUTINE mynn_bl_driver -!> @} + do in=kts,kte + x(in)=d(in)/b(in) + enddo + + return + end subroutine tridiag3 ! ================================================================== + !>\ingroup gsd_mynn_edmf SUBROUTINE mynn_bl_init_driver( & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & @@ -5639,14 +5702,14 @@ SUBROUTINE mynn_bl_init_driver( & LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART INTEGER,INTENT(IN) :: LEVEL !,icloud_bl - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE - REAL,DIMENSION(IMS:IME,KMS:KME),INTENT(INOUT) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & + REAL,DIMENSION(IMS:IME,KMS:KME),INTENT(INOUT) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & &QKE,EXCH_H INTEGER :: I,J,K,ITF,JTF,KTF @@ -5869,7 +5932,7 @@ SUBROUTINE DMP_mf( & & qt,qv,qc,qke, & & qnc,qni,qnwfa,qnifa, & & exner,vt,vq,sgm, & - & ust,flt,flq,flqv,flqc, & + & ust,flt,fltv,flq,flqv, & & pblh,kpbl,DX,landsea,ts, & ! outputs - updraft properties & edmf_a,edmf_w, & @@ -5885,10 +5948,9 @@ SUBROUTINE DMP_mf( & & sub_u,sub_v, & & det_thl,det_sqv,det_sqc, & & det_u,det_v, & -#if (WRF_CHEM == 1) - & nchem,chem,s_awchem, & - & mynn_chem_vertmx, & -#endif + ! chem/smoke + & nchem,chem1,s_awchem, & + & mix_chem, & ! in/outputs - subgrid scale clouds & qc_bl1d,cldfra_bl1d, & & qc_bl1D_old,cldfra_bl1D_old, & @@ -5917,7 +5979,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma - REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,& + REAL, INTENT(IN) :: DT,UST,FLT,FLTV,FLQ,FLQV,PBLH,& DX,Psig_shcu,landsea,ts LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA @@ -5943,7 +6005,7 @@ SUBROUTINE DMP_mf( & s_awv, & s_awqke, s_aw2 - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & + REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & qc_bl1d_old,cldfra_bl1d_old INTEGER, PARAMETER :: NUP=10, debug_mf=0 @@ -5951,7 +6013,7 @@ SUBROUTINE DMP_mf( & !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & + REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & UPQNI,UPQNWFA,UPQNIFA ! entrainment variables @@ -5959,21 +6021,21 @@ SUBROUTINE DMP_mf( & INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi ! internal variables INTEGER :: K,I,k50 - REAL :: fltv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & + REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & + REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters REAL,PARAMETER :: & - &Wa=2./3., & - &Wb=0.002,& + &Wa=2./3., & + &Wb=0.002, & &Wc=1.5 ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. REAL,PARAMETER :: & - & L0=100.,& + & L0=100., & & ENT0=0.1 ! Implement ideas from Neggers (2016, JAMES): @@ -5986,16 +6048,15 @@ SUBROUTINE DMP_mf( & ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx -#if (WRF_CHEM == 1) + ! chem/smoke INTEGER, INTENT(IN) :: nchem - REAL,DIMENSION(kts:kte, nchem) :: chem + REAL,DIMENSION(:, :) :: chem1 REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem REAL,DIMENSION(nchem) :: chemn REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM INTEGER :: ic REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem - LOGICAL, INTENT(IN) :: mynn_chem_vertmx -#endif + LOGICAL, INTENT(IN) :: mix_chem !JOE: add declaration of ERF REAL :: ERF @@ -6011,11 +6072,9 @@ SUBROUTINE DMP_mf( & ! Variables for plume interpolation/saturation check REAL,DIMENSION(KTS:KTE) :: exneri,dzi REAL :: THp, QTp, QCp, QCs, esat, qsl + REAL :: csigma,acfac,ac_wsp,ac_cld - ! WA TEST 11/9/15 for consistent reduction of updraft params - REAL :: csigma,acfac - - !JOE- plume overshoot + !plume overshoot INTEGER :: overshoot REAL :: bvf, Frz, dzp @@ -6073,11 +6132,10 @@ SUBROUTINE DMP_mf( & UPQNI=0. UPQNWFA=0. UPQNIFA=0. -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 - ENDIF -#endif + IF ( mix_chem ) THEN + UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 + ENDIF + ENT=0.001 ! Initialize mean updraft properties edmf_a =0. @@ -6086,11 +6144,10 @@ SUBROUTINE DMP_mf( & edmf_thl=0. edmf_ent=0. edmf_qc =0. -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - edmf_chem(kts:kte+1,1:nchem) = 0.0 - ENDIF -#endif + IF ( mix_chem ) THEN + edmf_chem(kts:kte+1,1:nchem) = 0.0 + ENDIF + ! Initialize the variables needed for implicit solver s_aw=0. s_awthl=0. @@ -6104,11 +6161,10 @@ SUBROUTINE DMP_mf( & s_awqni=0. s_awqnwfa=0. s_awqnifa=0. -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - s_awchem(kts:kte+1,1:nchem) = 0.0 - ENDIF -#endif + IF ( mix_chem ) THEN + s_awchem(kts:kte+1,1:nchem) = 0.0 + ENDIF + ! Initialize explicit tendencies for subsidence & detrainment sub_thl = 0. sub_sqv = 0. @@ -6127,7 +6183,7 @@ SUBROUTINE DMP_mf( & cloud_base = 9000.0 ! DO WHILE (ZW(k) < pblh + 500.) DO k=1,kte-1 - IF(ZW(k) > pblh + 500.) exit + IF(zw(k) > pblh + 500.) exit wpbl = w(k) IF(w(k) < 0.)wpbl = 2.*w(k) @@ -6138,7 +6194,6 @@ SUBROUTINE DMP_mf( & !Search for cloud base qc_sgs = MAX(qc(k), qc_bl1d(k)*cldfra_bl1d(k)) - !IF(qc(k) >1E-5 .AND. cloud_base == 9000.0)THEN IF(qc_sgs> 1E-5 .AND. cloud_base == 9000.0)THEN cloud_base = 0.5*(ZW(k)+ZW(k+1)) ENDIF @@ -6151,18 +6206,15 @@ SUBROUTINE DMP_mf( & Psig_w = MIN(Psig_w, Psig_shcu) !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu - fltv = flt + svp1*flq - !PRINT*," fltv=",fltv," zi=",pblh - !Completely shut off MF scheme for strong resolved-scale vertical velocities. - IF(Psig_w == 0.0 .and. fltv > 0.0) fltv = -1.*fltv + fltv2 = fltv + IF(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv -! if surface buoyancy is positive we do integration, otherwise not, and make sure that -! PBLH > twice the height of the surface layer (set at z0 = 50m) -! Also, ensure that it is at least slightly superadiabatic up through 50 m - superadiabatic = .false. + ! If surface buoyancy is positive we do integration, otherwise no. + ! Also, ensure that it is at least slightly superadiabatic up through 50 m + superadiabatic = .false. IF((landsea-1.5).GE.0)THEN - hux = -0.002 ! WATER ! dT/dz must be < - 0.2 K per 100 m. + hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m. ELSE hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. ENDIF @@ -6190,21 +6242,24 @@ SUBROUTINE DMP_mf( & ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist. ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes) - ! (5) land-only limit to reduce plume sizes in weakly forced conditions + ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only + ! meant to "soften" the activation of the mass-flux scheme. ! Criteria (1) NUP2 = max(1,min(NUP,INT(dx*dcut/dl))) !Criteria (2) - maxwidth = 1.2*PBLH + maxwidth = 1.1*PBLH ! Criteria (3) - maxwidth = MIN(maxwidth,0.666*cloud_base) + maxwidth = MIN(maxwidth,0.333*cloud_base) ! Criteria (4) wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01)) !Note: area fraction (acfac) is modified below - ! Criteria (5) - IF((landsea-1.5).LT.0)THEN + ! Criteria (5) - only a function of flt (not fltv) + if ((landsea-1.5).LT.0) then !land width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) - maxwidth = MIN(maxwidth,width_flx) - ENDIF + else !water + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.) + endif + maxwidth = MIN(maxwidth,width_flx) ! Convert maxwidth to number of plumes NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) @@ -6213,13 +6268,13 @@ SUBROUTINE DMP_mf( & ztop = 0.0 maxmf= 0.0 - IF ( fltv > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then - !PRINT*," Conditions met to run mass-flux scheme",fltv,pblh + IF ( fltv2 > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then + !PRINT*," Conditions met to run mass-flux scheme",fltv2,pblh ! Find coef C for number size density N cn = 0. d=-1.9 !set d to value suggested by Neggers 2015 (JAMES). - !d=-1.9 + .2*tanh((fltv - 0.05)/0.15) + !d=-1.9 + .2*tanh((fltv2 - 0.05)/0.15) do I=1,NUP !NUP2 IF(I > NUP2) exit l = dl*I ! diameter of plume @@ -6227,23 +6282,29 @@ SUBROUTINE DMP_mf( & enddo C = Atot/cn !Normalize C according to the defined total fraction (Atot) + ! Make updraft area (UPA) a function of the buoyancy flux + if ((landsea-1.5).LT.0) then !land + !acfac = .5*tanh((fltv2 - 0.03)/0.09) + .5 + acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5 + else !water + acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 + endif + !add a windspeed-dependent adjustment to acfac that tapers off + !the mass-flux scheme linearly above sfc wind speeds of 20 m/s: + ac_wsp = 1.0 - min(max(wspd_pbl - 20.0, 0.0), 10.0)/10.0 + !reduce area fraction beneath cloud bases < 1200 m AGL + ac_cld = min(cloud_base/1200., 1.0) + acfac = acfac * min(ac_wsp, ac_cld) + ! Find the portion of the total fraction (Atot) of each plume size: An2 = 0. do I=1,NUP !NUP2 IF(I > NUP2) exit l = dl*I ! diameter of plume - N = C*l**d ! number density of plume n + N = C*l**d ! number density of plume n UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n - ! Make updraft area (UPA) a function of the buoyancy flux -! acfac = .5*tanh((fltv - 0.03)/0.09) + .5 -! acfac = .5*tanh((fltv - 0.02)/0.09) + .5 - acfac = .5*tanh((fltv - 0.01)/0.09) + .5 - !add a windspeed-dependent adjustment to acfac that tapers off - !the mass-flux scheme linearly above sfc wind speeds of 20 m/s: - acfac = acfac*(1. - MIN(MAX(wspd_pbl - 20.0, 0.0), 10.0)/10.) - - UPA(1,I)=UPA(1,I)*acfac + UPA(1,I) = UPA(1,I)*acfac An2 = An2 + UPA(1,I) ! total fractional area of all plumes !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 end do @@ -6253,7 +6314,7 @@ SUBROUTINE DMP_mf( & pwmin=0.1 ! was 0.5 pwmax=0.4 ! was 3.0 - wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.)) + wstar=max(1.E-2,(gtr*fltv2*pblh)**(onethird)) qstar=max(flq,1.0E-5)/wstar thstar=flt/wstar @@ -6263,21 +6324,27 @@ SUBROUTINE DMP_mf( & csigma = 1.34 ! LAND ENDIF - IF (env_subs) THEN + if (env_subs) then exc_fac = 0.0 - ELSE - exc_fac = 0.58 - ENDIF + else + if ((landsea-1.5).GE.0) then + !water: increase factor to compensate for decreased pwmin/pwmax + exc_fac = 0.58*4.0*min(cloud_base/1000., 1.0) + else + !land: no need to increase factor - already sufficiently large superadiabatic layers + exc_fac = 0.58 + endif + endif !Note: sigmaW is typically about 0.5*wstar - sigmaW =1.34*wstar*(z0/pblh)**(1./3.)*(1 - 0.8*z0/pblh) - sigmaQT=csigma*qstar*(z0/pblh)**(-1./3.) - sigmaTH=csigma*thstar*(z0/pblh)**(-1./3.) + sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh) + sigmaQT=csigma*qstar*(z0/pblh)**(onethird) + sigmaTH=csigma*thstar*(z0/pblh)**(onethird) !Note: Given the pwmin & pwmax set above, these max/mins are ! rarely exceeded. - wmin=MIN(sigmaW*pwmin,0.05) - wmax=MIN(sigmaW*pwmax,0.4) + wmin=MIN(sigmaW*pwmin,0.1) + wmax=MIN(sigmaW*pwmax,0.5) !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 DO I=1,NUP !NUP2 @@ -6290,10 +6357,10 @@ SUBROUTINE DMP_mf( & UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQC(1,I)=0 + UPQC(1,I)=0.0 !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& - & +exc_fac*UPW(1,I)*sigmaQT/sigmaW + & +exc_fac*UPW(1,I)*sigmaQT/sigmaW UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & & +exc_fac*UPW(1,I)*sigmaTH/sigmaW !was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface @@ -6306,16 +6373,14 @@ SUBROUTINE DMP_mf( & UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) ENDDO -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN + IF ( mix_chem ) THEN DO I=1,NUP !NUP2 IF(I > NUP2) exit do ic = 1,nchem - UPCHEM(1,I,ic)=(CHEM(KTS,ic)*DZ(KTS+1)+CHEM(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPCHEM(1,I,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) enddo ENDDO ENDIF -#endif !Initialize environmental variables which can be modified by detrainment DO k=kts,kte @@ -6326,11 +6391,10 @@ SUBROUTINE DMP_mf( & envm_v(k)=V(k) ENDDO - !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport - dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) + !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport + dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) - !QCn = 0. - ! do integration updraft + ! do integration updraft DO I=1,NUP !NUP2 IF(I > NUP2) exit QCn = 0. @@ -6392,16 +6456,14 @@ SUBROUTINE DMP_mf( & !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - do ic = 1,nchem - ! Exponential Entrainment: - !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp - ! Linear entrainment: - chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem(k,ic)*EntExp - enddo - ENDIF -#endif + IF ( mix_chem ) THEN + do ic = 1,nchem + ! Exponential Entrainment: + !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp + ! Linear entrainment: + chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp + enddo + ENDIF ! Define pressure at model interface Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) @@ -6413,7 +6475,7 @@ SUBROUTINE DMP_mf( & THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) ! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) - B=g*(THVn/THVk - 1.0) + B=grav*(THVn/THVk - 1.0) IF(B>0.)THEN BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much ELSE @@ -6462,7 +6524,6 @@ SUBROUTINE DMP_mf( & ENDIF !Allow strongly forced plumes to overshoot if KE is sufficient - !IF (fltv > 0.05 .AND. Wn <= 0 .AND. overshoot == 0) THEN IF (Wn <= 0.0 .AND. overshoot == 0) THEN overshoot = 1 IF ( THVk-THVkm1 .GT. 0.0 ) THEN @@ -6472,20 +6533,15 @@ SUBROUTINE DMP_mf( & !IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) dzp = dz(k)*MAX(MIN(Frz,1.0),0.0) ! portion of highest layer the plume penetrates ENDIF - !ELSEIF (fltv > 0.05 .AND. overshoot == 1) THEN ELSE dzp = dz(k) - ! !Do not let overshooting parcel go more than 1 layer up - ! Wn = 0.0 ENDIF !Limit very tall plumes -! Wn2=Wn2*EXP(-MAX(ZW(k)-(pblh+2000.),0.0)/1000.) -! IF(ZW(k) >= pblh+3000.)Wn2=0. Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3500.),0.0)/1000.) !JOE- minimize the plume penetratration in stratocu-topped PBL - ! IF (fltv < 0.06) THEN + ! IF (fltv2 < 0.06) THEN ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. ! ENDIF @@ -6526,13 +6582,11 @@ SUBROUTINE DMP_mf( & UPQNWFA(K,I)=QNWFAn UPQNIFA(K,I)=QNIFAn UPA(K,I)=UPA(K-1,I) -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - do ic = 1,nchem - UPCHEM(k,I,ic) = chemn(ic) - enddo - ENDIF -#endif + IF ( mix_chem ) THEN + do ic = 1,nchem + UPCHEM(k,I,ic) = chemn(ic) + enddo + ENDIF ktop = MAX(ktop,k) ELSE exit !exit k-loop @@ -6542,7 +6596,7 @@ SUBROUTINE DMP_mf( & IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN ! surface values - print *,'flq:',flq,' fltv:',fltv,' Nup2=',Nup2 + print *,'flq:',flq,' fltv:',fltv2,' Nup2=',Nup2 print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT ! means @@ -6573,24 +6627,6 @@ SUBROUTINE DMP_mf( & !Calculate the fluxes for each variable !All s_aw* variable are == 0 at k=1 -! DO k=KTS,KTE -! IF(k > KTOP) exit -! DO i=1,NUP !NUP2 -! IF(I > NUP2) exit -! s_aw(k+1) = s_aw(k+1) + UPA(K,i)*UPW(K,i)*Psig_w -! s_awthl(k+1)= s_awthl(k+1) + UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w -! s_awqt(k+1) = s_awqt(k+1) + UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w -! s_awqc(k+1) = s_awqc(k+1) + UPA(K,i)*UPW(K,i)*UPQC(K,i)*Psig_w -! IF (momentum_opt > 0) THEN -! s_awu(k+1) = s_awu(k+1) + UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w -! s_awv(k+1) = s_awv(k+1) + UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w -! ENDIF -! IF (tke_opt > 0) THEN -! s_awqke(k+1)= s_awqke(k+1) + UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w -! ENDIF -! ENDDO -! s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) -! ENDDO DO i=1,NUP !NUP2 IF(I > NUP2) exit DO k=KTS,KTE-1 @@ -6618,8 +6654,8 @@ SUBROUTINE DMP_mf( & s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) ENDDO ENDDO -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN + + IF ( mix_chem ) THEN DO k=KTS,KTE IF(k > KTOP) exit rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) @@ -6631,7 +6667,6 @@ SUBROUTINE DMP_mf( & ENDDO ENDDO ENDIF -#endif IF (scalar_opt > 0) THEN DO k=KTS,KTE @@ -6679,11 +6714,9 @@ SUBROUTINE DMP_mf( & IF (tke_opt > 0) THEN s_awqke= s_awqke*adjustment ENDIF -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - s_awchem = s_awchem*adjustment - ENDIF -#endif + IF ( mix_chem ) THEN + s_awchem = s_awchem*adjustment + ENDIF UPA = UPA*adjustment ENDIF !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt @@ -6701,13 +6734,6 @@ SUBROUTINE DMP_mf( & edmf_thl(K)=edmf_thl(K)+rho_int*UPA(K,i)*UPTHL(K,i) edmf_ent(K)=edmf_ent(K)+rho_int*UPA(K,i)*ENT(K,i) edmf_qc(K) =edmf_qc(K) +rho_int*UPA(K,i)*UPQC(K,i) -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic) - enddo - ENDIF -#endif ENDDO !Note that only edmf_a is multiplied by Psig_w. This takes care of the @@ -6718,19 +6744,32 @@ SUBROUTINE DMP_mf( & edmf_thl(k)=edmf_thl(k)/edmf_a(k) edmf_ent(k)=edmf_ent(k)/edmf_a(k) edmf_qc(k)=edmf_qc(k)/edmf_a(k) -#if (WRF_CHEM == 1) - IF ( mynn_chem_vertmx ) THEN - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) - enddo - ENDIF -#endif edmf_a(k)=edmf_a(k)*Psig_w !FIND MAXIMUM MASS-FLUX IN THE COLUMN: IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) ENDIF - ENDDO + ENDDO ! end k + + !smoke/chem + IF ( mix_chem ) THEN + DO k=KTS,KTE-1 + IF(k > KTOP) exit + rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + DO I=1,NUP !NUP2 + IF(I > NUP2) exit + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic) + enddo + ENDDO + + IF (edmf_a(k)>0.) THEN + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) + enddo + ENDIF + ENDDO ! end k + ENDIF !Calculate the effects environmental subsidence. !All envi_*variables are valid at the interfaces, like the edmf_* variables @@ -6818,11 +6857,7 @@ SUBROUTINE DMP_mf( & IF(k > KTOP) exit IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN - satvp = 3.80*exp(17.27*(th(k)-273.)/ & - (th(k)-36.))/(.01*p(k)) - rhgrid = max(.01,MIN( 1., qv(k) /satvp)) - - !then interpolate plume thl, th, and qt to mass levels + !interpolate plume thl, th, and qt to mass levels THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) !convert TH to T @@ -6836,11 +6871,10 @@ SUBROUTINE DMP_mf( & IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) ELSE - QCp = MAX(0.0, QTp-qsl) + QCp = MAX(edmf_qc(k),edmf_qc(k-1)) ENDIF !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - xl = xl_blend(tk(k)) ! obtain blended heat capacity tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio @@ -6879,14 +6913,15 @@ SUBROUTINE DMP_mf( & qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; ! the numerator of Q1 - mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) - IF ( debug_code ) THEN - print*,"In MYNN, StEM edmf" - print*," CB: env qt=",qt(k)," qsat=",qsat_tl - print*," k=",k," satdef=",QTp - qsat_tl," sgm=",sgm(k) - print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk - print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) - ENDIF + mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + + !IF ( debug_code ) THEN + ! print*,"In MYNN, StEM edmf" + ! print*," CB: env qt=",qt(k)," qsat=",qsat_tl + ! print*," k=",k," satdef=",QTp - qsat_tl," sgm=",sgm(k) + ! print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk + ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) + !ENDIF ! Update cloud fractions and specific humidities in grid cells ! where the mass-flux scheme is active. Now, we also use the @@ -6958,7 +6993,7 @@ SUBROUTINE DMP_mf( & ! IF (edmf_w(1) > 4.0) THEN ! surface values - print *,'flq:',flq,' fltv:',fltv + print *,'flq:',flq,' fltv:',fltv2 print *,'pblh:',pblh,' wstar:',wstar print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT ! means @@ -7021,7 +7056,7 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! rcp ... Rd/cp ! xlv ... latent heat for water (2.5e6) ! cp -! rvord .. rv/rd (1.6) +! rvord .. r_v/r_d (1.6) ! number of iterations niter=50 @@ -7158,7 +7193,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & REAL :: jump_thetav, jump_qt, jump_thetal, & refTHL, refTHV, refQT ! DD specific internal variables - REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd, deltaZ + REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,& @@ -7175,7 +7210,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & & L0=80,& & ENT0=0.2 - pwmin=-3. ! drawing from the neagtive tail -3sigma to -1sigma + pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma pwmax=-1. ! initialize downdraft properties @@ -7240,7 +7275,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & F0 = 0. do k = 1, qlTop ! Snippet from YSU, YSU loops until qlTop - 1 radflux = rthraten(k) * exner(k) ! Converts theta/s to temperature/s - radflux = radflux * cp / g * ( p(k) - p(k+1) ) ! Converts K/s to W/m^2 + radflux = radflux * cp / grav * ( p(k) - p(k+1) ) ! Converts K/s to W/m^2 if ( radflux < 0.0 ) F0 = abs(radflux) + F0 enddo F0 = max(F0, 1.0) @@ -7278,10 +7313,10 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & refQT = qt(qlTop) !sum(qt(1:qlTop)) / (qlTop) ! wstar_rad, following Lock and MacVean (1999a) - wst_rad = ( g * zw(qlTop) * F0 / (refTHL * rho(qlTop) * cp) ) ** (0.333) + wst_rad = ( grav * zw(qlTop) * F0 / (refTHL * rho(qlTop) * cp) ) ** (0.333) wst_rad = max(wst_rad, 0.1) - wstar = max(0.,(g/thv(1)*wthv*pblh)**(1./3.)) - went = thv(1) / ( g * jump_thetav * zw(qlTop) ) * & + wstar = max(0.,(grav/thv(1)*wthv*pblh)**(onethird)) + went = thv(1) / ( grav * jump_thetav * zw(qlTop) ) * & (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) qstar = abs(went*jump_qt/wst_rad) thstar = F0/rho(qlTop)/cp/wst_rad - went*jump_thetav/wst_rad @@ -7340,13 +7375,12 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & !print*, " Begin integration of downdrafts:" DO I=1,NDOWN !print *, "Plume # =", I,"=======================" - DO k=DD_initK(I)-1,KTS+1,-1 + DO k=DD_initK(I)-1,KTS+1,-1 !starting at the first interface level below cloud top - deltaZ = ZW(k+1)-ZW(k) - !EntExp=exp(-ENT(K,I)*deltaZ) - !EntExp_M=exp(-ENT(K,I)/3.*deltaZ) - EntExp =ENT(K,I)*deltaZ - EntExp_M=ENT(K,I)*0.333*deltaZ + !EntExp=exp(-ENT(K,I)*dz(k)) + !EntExp_M=exp(-ENT(K,I)/3.*dz(k)) + EntExp =ENT(K,I)*dz(k) + EntExp_M=ENT(K,I)*0.333*dz(k) QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp @@ -7362,31 +7396,31 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & ! given new p & z, solve for thvn & qcn Pk =(P(k-1)*DZ(k)+P(k)*DZ(k-1))/(DZ(k)+DZ(k-1)) call condensation_edmf(QTn,THLn,Pk,ZW(k),THVn,QCn) -! B=g*(0.5*(THVn+DOWNTHV(k+1,I))/THV(k)-1.) +! B=grav*(0.5*(THVn+DOWNTHV(k+1,I))/THV(k)-1.) THVk =(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k)+DZ(k-1)) - B=g*(THVn/THVk - 1.0) -! Beta_dm = 2*Wb*ENT(K,I) + 0.5/(ZW(k)-deltaZ) * & -! & max(1. - exp((ZW(k) -deltaZ)/Z00 - 1. ) , 0.) -! EntW=exp(-Beta_dm * deltaZ) + B=grav*(THVn/THVk - 1.0) +! Beta_dm = 2*Wb*ENT(K,I) + 0.5/(ZW(k)-dz(k)) * & +! & max(1. - exp((ZW(k) -dz(k))/Z00 - 1. ) , 0.) +! EntW=exp(-Beta_dm * dz(k)) EntW=EntExp ! if (Beta_dm >0) then ! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW) ! else -! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*deltaZ +! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*dz(k) ! end if mindownw = MIN(DOWNW(K+1,I),-0.2) Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - & - BCOEFF*B/mindownw)*MIN(deltaZ, 250.) + BCOEFF*B/mindownw)*MIN(dz(k), 250.) !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. !Add max increase of 2.0 m/s for coarse vertical resolution. - IF (Wn < DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0))THEN - Wn = DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0) + IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0))THEN + Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0) ENDIF !Add symmetrical max decrease in w - IF (Wn > DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0))THEN - Wn = DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0) + IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN + Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0) ENDIF Wn = MAX(MIN(Wn,0.0), -3.0) @@ -7557,19 +7591,19 @@ FUNCTION esat_blend(t) REAL, INTENT(IN):: t REAL :: esat_blend,XC,ESL,ESI,chi - XC=MAX(-80.,t-273.16) + XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common ! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, ! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting ! values are returned from the function. - IF (t .GE. 273.16) THEN + IF (t .GE. t0c) THEN esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ELSE IF (t .LE. 253.) THEN + ELSE IF (t .LE. tice) THEN esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - chi = (273.16-t)/20.16 + chi = (t0c - t)/(t0c - tice) esat_blend = (1.-chi)*ESL + chi*ESI END IF @@ -7596,21 +7630,23 @@ FUNCTION qsat_blend(t, P, waterice) wrt = waterice ENDIF - XC=MAX(-80.,t-273.16) + XC=MAX(-80.,t - t0c) - IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN + IF ((t .GE. t0c) .OR. (wrt .EQ. 'w')) THEN ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - qsat_blend = 0.622*ESL/(P-ESL) - ELSE IF (t .LE. 253.) THEN + qsat_blend = 0.622*ESL/max(P-ESL, 1e-5) +! ELSE IF (t .LE. 253.) THEN + ELSE IF (t .LE. tice) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - qsat_blend = 0.622*ESI/(P-ESI) + qsat_blend = 0.622*ESI/max(P-ESI, 1e-5) ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - RSLF = 0.622*ESL/(P-ESL) - RSIF = 0.622*ESI/(P-ESI) - chi = (273.16-t)/20.16 - qsat_blend = (1.-chi)*RSLF + chi*RSIF + RSLF = 0.622*ESL/max(P-ESL, 1e-5) + RSIF = 0.622*ESI/max(P-ESI, 1e-5) +! chi = (273.16-t)/20.16 + chi = (t0c - t)/(t0c - tice) + qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF END FUNCTION qsat_blend @@ -7628,15 +7664,18 @@ FUNCTION xl_blend(t) REAL, INTENT(IN):: t REAL :: xl_blend,xlvt,xlst,chi + !note: t0c = 273.15, tice is set in mynn_common - IF (t .GE. 273.16) THEN - xl_blend = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation - ELSE IF (t .LE. 253.) THEN - xl_blend = xls + (cpv-cice)*(t-273.16) !sublimation/deposition + IF (t .GE. t0c) THEN + xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation +! ELSE IF (t .LE. 253.) THEN + ELSE IF (t .LE. tice) THEN + xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition ELSE - xlvt = xlv + (cpv-cliq)*(t-273.16) !vaporization/condensation - xlst = xls + (cpv-cice)*(t-273.16) !sublimation/deposition - chi = (273.16-t)/20.16 + xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation + xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition +! chi = (273.16-t)/20.16 + chi = (t0c - t)/(t0c - tice) xl_blend = (1.-chi)*xlvt + chi*xlst !blended END IF @@ -7799,13 +7838,13 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & templ=thl(k)*ex1(k) !rvls is ws at full level rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) - temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(rd*templ**2)) + temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(r_d*templ**2)) rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) rcldb=max(sqw(k)-rvls,0.) !entrainment efficiency - dthvx = (thl(k+2) + th1(k+2)*ep_1*sqw(k+2)) & - - (thl(k) + th1(k) *ep_1*sqw(k)) + dthvx = (thl(k+2) + th1(k+2)*p608*sqw(k+2)) & + - (thl(k) + th1(k) *p608*sqw(k)) dthvx = max(dthvx,0.1) tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) !Originally from Nichols and Turton (1986), where a2 = 60, but lowered @@ -7815,7 +7854,7 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & radsum=0. DO kk = MAX(1,kpbl-3),kpbl+3 radflux=rthraten(kk)*ex1(kk) !converts theta/s to temp/s - radflux=radflux*cp/g*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 + radflux=radflux*cp/grav*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 if (radflux < 0.0 ) radsum=abs(radflux)+radsum ENDDO @@ -7829,7 +7868,7 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & endif !entrainment from PBL top thermals - wm3 = g/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) + wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) wm2 = wm2 + wm3**h2 bfxpbl = - ent_eff * bfx0 dthvx = max(thetav(k+1)-thetav(k),0.1)