From cb5fd666cae8e0e6fdbdacd5143cbfc608760392 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 15 Dec 2021 10:47:52 -0700 Subject: [PATCH 01/37] Add Sam Trahan to CODEOWNERS --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 5080ce409..f8492f59f 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @climbfuji @grantfirl @mzhangw @panll @mkavulich +* @SamuelTrahanNOAA @DomHeinzeller # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 601d38eae125a3f2cfb0c226ba8100f74b4bdcb6 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 2 Feb 2022 02:17:03 +0000 Subject: [PATCH 02/37] Updates to MYNN-EDMF, part I - goes withmods for fv3atm --- physics/module_MYNNPBL_wrapper.F90 | 452 +- physics/module_MYNNPBL_wrapper.meta | 227 +- physics/module_bl_mynn.F90 | 9947 ++++++++++++++------------- 3 files changed, 5418 insertions(+), 5208 deletions(-) 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..b954ef7bc 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 == .true.) 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 == .true.) 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 == .true.) 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 == .true.) 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 == .true.) 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) From 54e6476d12654de86621798572406c4f01f36ff1 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Thu, 10 Feb 2022 16:08:06 +0000 Subject: [PATCH 03/37] Removing .eq. from logical if-then tests. --- physics/module_bl_mynn.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index b954ef7bc..3ab549e98 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -795,7 +795,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO ENDDO - IF ( bl_mynn_tkebudget == .true.) THEN + IF ( bl_mynn_tkebudget ) THEN DO k=KTS,KTE DO i=ITS,ITF qWT(i,k)=0. @@ -969,7 +969,7 @@ SUBROUTINE mynn_bl_driver( & DO i=ITS,ITF DO k=KTS,KTE !KTF !JOE-TKE BUDGET - IF ( bl_mynn_tkebudget == .true.) THEN + IF ( bl_mynn_tkebudget ) THEN dqke(i,k)=qke(i,k) END IF IF (icloud_bl > 0) THEN @@ -1519,7 +1519,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO !end-k - IF ( bl_mynn_tkebudget == .true.) THEN + 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 @@ -3279,7 +3279,7 @@ SUBROUTINE mym_turbulence ( & dfq(k) = dfm(k) ! Modified: Dec/22/2005, up to here - IF ( bl_mynn_tkebudget == .true.) THEN + IF ( bl_mynn_tkebudget ) THEN !TKE BUDGET ! dudz = ( u(k)-u(k-1) )/dzk ! dvdz = ( v(k)-v(k-1) )/dzk @@ -3565,7 +3565,7 @@ SUBROUTINE mym_predict (kts,kte, & !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - IF (bl_mynn_tkebudget == .true.) THEN + IF (bl_mynn_tkebudget) THEN !! TKE Vertical transport << EOBvt tke_up=0.5*qke dzinv=1./dz From 0278c104503ae9c94e50e53a80ad2e7a90165369 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 16 Feb 2022 03:56:21 +0000 Subject: [PATCH 04/37] Updating SGS cloud interstitial to add Chab-Becht cloud fraction and SGS snow. --- physics/module_SGSCloud_RadPost.F90 | 9 +- physics/module_SGSCloud_RadPost.meta | 16 ++ physics/module_SGSCloud_RadPre.F90 | 234 +++++++++++++++++---------- physics/module_SGSCloud_RadPre.meta | 112 ++++++++++++- 4 files changed, 277 insertions(+), 94 deletions(-) diff --git a/physics/module_SGSCloud_RadPost.F90 b/physics/module_SGSCloud_RadPost.F90 index ea262596f..c94d2dda1 100644 --- a/physics/module_SGSCloud_RadPost.F90 +++ b/physics/module_SGSCloud_RadPost.F90 @@ -21,8 +21,8 @@ end subroutine sgscloud_radpost_finalize subroutine sgscloud_radpost_run( & im,levs, & flag_init,flag_restart, & - qc,qi, & - qc_save,qi_save, & + qc,qi,qs, & + qc_save,qi_save,qs_save, & errmsg,errflg ) ! should be moved to inside the mynn: @@ -34,8 +34,8 @@ subroutine sgscloud_radpost_run( & integer, intent(in) :: im, levs logical, intent(in) :: flag_init, flag_restart - real(kind=kind_phys), dimension(:,:), intent(inout) :: qc, qi - real(kind=kind_phys), dimension(:,:), intent(in) :: qc_save, qi_save + real(kind=kind_phys), dimension(:,:), intent(inout) :: qc, qi, qs + real(kind=kind_phys), dimension(:,:), intent(in) :: qc_save, qi_save, qs_save character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variable @@ -58,6 +58,7 @@ subroutine sgscloud_radpost_run( & do i = 1, im qc(i,k) = qc_save(i,k) qi(i,k) = qi_save(i,k) + qs(i,k) = qs_save(i,k) enddo enddo diff --git a/physics/module_SGSCloud_RadPost.meta b/physics/module_SGSCloud_RadPost.meta index 7298426ae..ed316433b 100644 --- a/physics/module_SGSCloud_RadPost.meta +++ b/physics/module_SGSCloud_RadPost.meta @@ -51,6 +51,14 @@ type = real kind = kind_phys intent = inout +[qs] + standard_name = snow_mixing_ratio + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [qc_save] standard_name = cloud_condensed_water_mixing_ratio_save long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme @@ -67,6 +75,14 @@ type = real kind = kind_phys intent = in +[qs_save] + standard_name = snow_mixing_ratio_save + long_name = cloud snow mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/module_SGSCloud_RadPre.F90 index 68a520a84..02b400859 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/module_SGSCloud_RadPre.F90 @@ -36,81 +36,105 @@ end subroutine sgscloud_radpre_finalize !! clouds(:,:,3) - mean effective radius for liquid cloud ! !! clouds(:,:,4) - layer cloud ice water path ! !! clouds(:,:,5) - mean effective radius for ice cloud ! +!! clouds(:,:,6) - layer rain drop water path ! +!! clouds(:,:,7) - mean effective radius for rain drop ! +!! clouds(:,:,8) - layer snow flake water path ! +!! clouds(:,:,9) - mean effective radius for snow flake !! !>\section sgscloud_radpre GSD SGS Scheme General Algorithm !> @{ subroutine sgscloud_radpre_run( & - im,levs, & + im,dt,levs, & flag_init,flag_restart, & con_g, con_pi, eps, epsm1, & + r_v, cpv, rcp, & + xlv, xlf, cp, & do_mynnedmf, & - qc, qi, qv, T3D, P3D, & + qc, qi, qv, T3D, P3D, exner, & qr, qs, qg, & - qci_conv, & + qci_conv,ud_mf, & imfdeepcnv, imfdeepcnv_gf, & - qc_save, qi_save, & + qc_save, qi_save, qs_save, & qc_bl,qi_bl,cldfra_bl, & delp,clouds1,clouds2,clouds3, & - clouds4,clouds5,slmsk, & + clouds4,clouds5, & + clouds8,clouds9,slmsk, & nlay, plyr, xlat, dz,de_lgth, & cldsa,mtopa,mbota, & imp_physics, imp_physics_gfdl,& iovr, & errmsg, errflg ) -! should be moved to inside the mynn: use machine , only : kind_phys use module_radiation_clouds, only : gethml - use radcons, only: qmin ! Minimum values for various calculations - use funcphys, only: fpvs ! Function ot compute sat. vapor pressure over liq. + use radcons, only: qmin ! Minimum values for various calculations + use funcphys, only: fpvs ! Function to compute sat. vapor pressure over liq. !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- ! Interface variables - real(kind=kind_phys), intent(in) :: con_g, con_pi, eps, epsm1 - real (kind=kind_phys) :: gfac - integer, intent(in) :: im, levs, imfdeepcnv, imfdeepcnv_gf, & + real(kind=kind_phys), intent(in) :: con_g, con_pi, eps, epsm1 + real(kind=kind_phys), intent(in) :: r_v, cpv, rcp + real(kind=kind_phys), intent(in) :: xlv, xlf, cp + real(kind=kind_phys), intent(in) :: dt + real :: xls, xlvcp, xlscp !derived below + real(kind=kind_phys) :: gfac + integer, intent(in) :: im, levs, imfdeepcnv, imfdeepcnv_gf, & & nlay, imp_physics, imp_physics_gfdl - logical, intent(in) :: flag_init, flag_restart, do_mynnedmf + logical, intent(in) :: flag_init, flag_restart, do_mynnedmf + real(kind=kind_phys), dimension(:,:), intent(inout) :: qc, qi real(kind=kind_phys), dimension(:,:), intent(inout) :: qr, qs, qg ! qci_conv only allocated if GF is used - real(kind=kind_phys), dimension(:,:), intent(inout) :: qci_conv - real(kind=kind_phys), dimension(:,:), intent(in) :: T3D,delp, & - & qv,P3D - real(kind=kind_phys), dimension(:,:), intent(inout) :: & - & clouds1,clouds2,clouds3,clouds4,clouds5 - real(kind=kind_phys), dimension(:,:), intent(inout) :: qc_save, qi_save + real(kind=kind_phys), dimension(:,:), intent(inout) :: qci_conv + real(kind=kind_phys), dimension(:,:), intent(in) :: ud_mf + real(kind=kind_phys), dimension(:,:), intent(in) :: T3D,delp + real(kind=kind_phys), dimension(:,:), intent(in) :: qv,P3D,exner + real(kind=kind_phys), dimension(:,:), intent(inout) :: & + & clouds1,clouds2,clouds3,clouds4,clouds5, & + & clouds8,clouds9 + real(kind=kind_phys), dimension(:,:), intent(inout) :: qc_save, qi_save, qs_save real(kind=kind_phys), dimension(:,:), intent(in) :: qc_bl, qi_bl, cldfra_bl - real(kind=kind_phys), dimension(:), intent(in) :: slmsk, xlat, de_lgth + real(kind=kind_phys), dimension(:), intent(in) :: slmsk, xlat, de_lgth real(kind=kind_phys), dimension(:,:), intent(in) :: plyr, dz - real(kind=kind_phys), dimension(:,:), intent(inout) :: cldsa - integer, dimension(:,:), intent(inout) :: mbota, mtopa - integer, intent(in) :: iovr + real(kind=kind_phys), dimension(:,:), intent(inout) :: cldsa + integer, dimension(:,:), intent(inout) :: mbota, mtopa + integer, intent(in) :: iovr character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variables ! pressure limits of cloud domain interfaces (low,mid,high) in mb (0.1kPa) - real (kind=kind_phys) :: ptop1(im,3+1) !< pressure limits of cloud domain interfaces - real (kind=kind_phys) :: ptopc(3+1,2 ) !< pressure limits of cloud domain interfaces - !! (low, mid, high) in mb (0.1kPa) + real(kind=kind_phys) :: ptop1(im,3+1) !< pressure limits of cloud domain interfaces + real(kind=kind_phys) :: ptopc(3+1,2 ) !< pressure limits of cloud domain interfaces + !! (low, mid, high) in mb (0.1kPa) data ptopc / 1050., 650., 400., 0.0, 1050., 750., 500., 0.0 / real(kind=kind_phys), dimension(im,nlay) :: cldcnv real(kind=kind_phys), dimension(im) :: rxlat - real (kind=kind_phys):: Tc, iwc + real(kind=kind_phys) :: Tc, Tk, liqfrac, iwc, ice_frac, snow_frac integer :: i, k, id ! DH* 20200723 - see comment at the end of this routine around 'gethml' real(kind=kind_phys), dimension(im,nlay) :: alpha_dummy ! *DH ! PARAMETERS FOR RANDALL AND XU (1996) CLOUD FRACTION - REAL, PARAMETER :: coef_p = 0.25, coef_gamm = 0.49, coef_alph = 100. - REAL :: rhgrid,h2oliq,qsat,tem1,tem2,clwt,es,onemrh,value + real, parameter :: coef_p = 0.25, coef_gamm = 0.49, coef_alph = 100. + real :: rhgrid,h2oliq,qsat,tem1,tem2,clwt,es,onemrh,value + + !Chaboureau and Bechtold (2002 and 2005) + real :: a, f, sigq, qmq, qt, xl, tlk, th, thl, rsl, cpm, cb_cf + + !Option to convective cloud fraction + integer, parameter :: conv_cf_opt = 0 !0: C-B, 1: X-R ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + ! some derived variables from incoming constants: + xls=xlv+xlf + xlvcp=xlv/cp + xlscp=(xlv+xlf)/cp + !write(0,*)"==============================================" !write(0,*)"in SGSCLoud_RadPre" gfac=1.0e5/con_g @@ -151,6 +175,7 @@ subroutine sgscloud_radpre_run( & do i = 1, im qc_save(i,k) = qc(i,k) qi_save(i,k) = qi(i,k) + qs_save(i,k) = qs(i,k) end do end do @@ -171,39 +196,47 @@ subroutine sgscloud_radpre_run( & clouds1(i,k) = cldfra_bl(i,k) !endif - !if( qr(i,k) > 1.0e-7 .OR. qs(i,k) > 1.0e-7.or.qci_conv(i,k)>1.0e-7)THEN - !Keep Xu-RandalL clouds fraction - do not overwrite - !else - ! clouds1(i,k) = cldfra_bl(i,k) - !endif - if (qc(i,k) < 1.e-6 .and. cldfra_bl(i,k)>0.001) then qc(i,k) = qc_bl(i,k)*cldfra_bl(i,k) + + !eff radius cloud water (microns) from Miles et al. (2007) if (nint(slmsk(i)) == 1) then !land - if(qc(i,k)>1.E-8)clouds3(i,k)=5.4 !eff radius cloud water (microns) + if(qc(i,k)>1.E-8)clouds3(i,k)=5.4 else - !eff radius cloud water (microns), from Miles et al. if(qc(i,k)>1.E-8)clouds3(i,k)=9.6 endif + !calculate the liquid water path using additional BL clouds clouds2(i,k) = max(0.0, qc(i,k) * gfac * delp(i,k)) endif + + Tc = T3D(i,k) - 273.15 + !crudely split frozen species into 50% ice and 50% snow below + !~700 mb and decrease snow to zero by ~300 mb + snow_frac = min(0.5, max((p3d(i,k)-30000.0),0.0)/140000.0) + ice_frac = 1.0 - snow_frac if (qi(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then - qi(i,k) = qi_bl(i,k)*cldfra_bl(i,k) - Tc = T3D(i,k) - 273.15 + qi(i,k) = ice_frac*qi_bl(i,k)*cldfra_bl(i,k) + + !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) + if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) + !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 8b) !iwc = qi(i,k)*1.0e6*rho(i,k) - if (nint(slmsk(i)) == 1) then !land - !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) - if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) - else - if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) - !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 8b) - !IF(qi(i,k)>1.E-8)clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.) - endif + !IF(qi(i,k)>1.E-8)clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.) + !calculate the ice water path using additional BL clouds clouds4(i,k) = max(0.0, qi(i,k) * gfac * delp(i,k)) endif + if (qs(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then + qs(i,k) = snow_frac*qi_bl(i,k)*cldfra_bl(i,k) + + !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) + if(qs(i,k)>1.E-8)clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.) + + !calculate the snow water path using additional BL clouds + clouds8(i,k) = max(0.0, qs(i,k) * gfac * delp(i,k)) + endif enddo enddo @@ -241,55 +274,92 @@ subroutine sgscloud_radpre_run( & endif ! end MYNN or OTHER choice for background clouds fractions ! At this point, we have cloud properties for all non-deep convective clouds. - ! So now we add the convective clouds, + ! So now we add the convective clouds: if (imfdeepcnv == imfdeepcnv_gf) then do k = 1, levs do i = 1, im !if ( qci_conv(i,k) > 0. .AND. (qi(i,k) < 1E-7 .AND. qc(i,k) < 1E-7 ) ) then if ( qci_conv(i,k) > 0. ) then - !Partition the convective clouds into water & ice according to a linear - qc(i,k) = qc(i,k)+qci_conv(i,k)*(min(1., max(0., (T3D(i,k)-244.)/25.))) - qi(i,k) = qi(i,k)+qci_conv(i,k)*(1. - min(1., max(0., (T3D(i,k)-244.)/25.))) + Tk = T3D(i,k) + Tc = Tk - 273.15 - Tc = T3D(i,k) - 273.15 + !Partition the convective clouds into water & frozen species + liqfrac = min(1., max(0., (Tk-244.)/29.)) + qc(i,k) = qc(i,k)+qci_conv(i,k)*liqfrac + !split ice & snow 50-50% + qi(i,k) = qi(i,k)+0.5*qci_conv(i,k)*(1. - liqfrac) + qs(i,k) = qs(i,k)+0.5*qci_conv(i,k)*(1. - liqfrac) + !eff radius cloud water (microns) if (nint(slmsk(i)) == 1) then !land - if(qc(i,k)>1.E-8)clouds3(i,k)=5.4 !eff radius cloud water (microns) - !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos) - if(qi(i,k)>1.e-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) + if(qc(i,k)>1.E-8)clouds3(i,k)=5.4 else - !eff radius cloud water (microns), from Miles et al. + !from Miles et al. if(qc(i,k)>1.E-8)clouds3(i,k)=9.6 - !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) - if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) endif - - if ( do_mynnedmf ) then - !print *,'MYNN PBL cldcov used' + !from Mishra et al. (2014, JGR Atmos), assume R_sno = 2*R_ice + if(qi(i,k)>1.e-8)clouds5(i,k)=max( 173.45 + 2.14*Tc , 20.) + if(qs(i,k)>1.e-8)clouds9(i,k)=max(2.0*(173.45 + 2.14*Tc), 50.) + + if ( conv_cf_opt .eq. 0 ) then + !print *,'Chab-Bechtold cloud fraction used' + ! clouds1(i,k) = cldfra_bl(i,k) + + !Alternatively, use Chaboureau-Bechtold (CB) convective component + !Based on both CB2002 and CB2005. + xl = xlv*liqfrac + xls*(1.-liqfrac) ! blended heat capacity + tlk = t3d(i,k) - xlvcp/exner(i,k)*qc(i,k) & + & - xlscp/exner(i,k)*qi(i,k)! liquid temp + ! get saturation water vapor mixing ratio at tl and p + es = min( p3d(i,k), fpvs( tlk ) ) ! fpvs and prsl in pa + qsat= max( QMIN, eps*es / (p3d(i,k) + epsm1*es) ) + rsl = xl*qsat / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + qt = qc(i,k) + qi(i,k) + qv(i,k) !total water + cpm = cp + qt*cpv ! CB02, sec. 2, para. 1 + a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + !Now calculate convective component of the cloud fraction: + if (a > 0.0) then + f = min(1.0/a, 4.0) ! f is the vertical profile + else ! scaling function (CB2005) + f = 1.0 + endif + sigq = 1.5E-3 * ud_mf(i,k)/dt * f + !sigq = 3.E-3 * ud_mf(i,k)/dt * f + sigq = SQRT(sigq**2 + 1e-10) ! combined conv + background components + qmq = a * (qt - qsat) ! saturation deficit/excess; + ! the numerator of Q1 + cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.99) + if (do_mynnedmf .and. qmq .ge. 0.0) then + ! leverage C-B stratus clouds from MYNN in saturated conditions + clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + else ! unsaturated + clouds1(i,k) = cb_cf + endif else - !print *,'GF with Xu-Randall cloud fraction' - ! Xu-Randall (1996) cloud fraction - es = min( p3d(i,k), fpvs( t3d(i,k) ) ) ! fpvs and prsl in pa - qsat = max( QMIN, eps * es / (p3d(i,k) + epsm1*es) ) - rhgrid = max( 0., min( 1.00, qv(i,k)/qsat ) ) - h2oliq = qc(i,k) + qi(i,k) + qr(i,k) + qs(i,k) + qg(i,k) ! g/kg - clwt = 1.0e-6 * (p3d(i,k)*0.00001) - - if (h2oliq > clwt) then - onemrh= max( 1.e-10, 1.0-rhgrid ) - tem1 = min(max((onemrh*qsat)**0.49,0.0001),1.0) !jhan - tem1 = 100.0 / tem1 - value = max( min( tem1*(h2oliq-clwt), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhgrid) ) - - clouds1(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - else - clouds1(i,k) = 0.0 - endif - !print*,"XuRandla- cf:",clouds1(i,k)," rh:",rhgrid," qt:",h2oliq - !print*,"XuRandlb- clwt:",clwt," qsat:",qsat," p:",p3d(i,k) - endif ! not MYNN PBL + !print *,'GF with Xu-Randall cloud fraction' + ! Xu-Randall (1996) cloud fraction + es = min( p3d(i,k), fpvs( t3d(i,k) ) ) ! fpvs and prsl in pa + qsat = max( QMIN, eps*es / (p3d(i,k) + epsm1*es) ) + rhgrid = max( 0., min( 1.00, qv(i,k)/qsat ) ) + h2oliq = qc(i,k) + qi(i,k) + qr(i,k) + qs(i,k) + qg(i,k) ! g/kg + clwt = 1.0e-6 * (p3d(i,k)*0.00001) + + if (h2oliq > clwt) then + onemrh= max( 1.e-10, 1.0-rhgrid ) + tem1 = min(max((onemrh*qsat)**0.49,0.0001),1.0) !jhan + tem1 = 100.0 / tem1 + value = max( min( tem1*(h2oliq-clwt), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhgrid) ) + + clouds1(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + else + clouds1(i,k) = 0.0 + endif + !print*,"XuRandla- cf:",clouds1(i,k)," rh:",rhgrid," qt:",h2oliq + !print*,"XuRandlb- clwt:",clwt," qsat:",qsat," p:",p3d(i,k) + endif ! end convective cf choice endif ! qci_conv enddo enddo diff --git a/physics/module_SGSCloud_RadPre.meta b/physics/module_SGSCloud_RadPre.meta index 14c3127fc..95d73432d 100644 --- a/physics/module_SGSCloud_RadPre.meta +++ b/physics/module_SGSCloud_RadPre.meta @@ -14,6 +14,14 @@ dimensions = () type = integer intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in [levs] standard_name = vertical_layer_dimension long_name = vertical layer dimension @@ -67,6 +75,54 @@ type = real kind = kind_phys intent = in +[r_v] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[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 + dimensions = () + type = real + kind = kind_phys + intent = in +[rcp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[xlv] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[xlf] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [do_mynnedmf] standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme long_name = flag to activate MYNN-EDMF @@ -90,6 +146,14 @@ type = real kind = kind_phys intent = inout +[qs] + standard_name = snow_mixing_ratio + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [qv] standard_name = specific_humidity long_name = water vapor specific humidity @@ -114,17 +178,17 @@ type = real kind = kind_phys intent = in -[qr] - standard_name = rain_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of rain water - units = kg kg-1 +[exner] + standard_name = dimensionless_exner_function + long_name = Exner function at layers + units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = inout -[qs] - standard_name = snow_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of snow water + intent = in +[qr] + standard_name = rain_mixing_ratio + long_name = moist (dry+vapor, no condensates) mixing ratio of rain water units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real @@ -138,6 +202,14 @@ type = real kind = kind_phys intent = inout +[ud_mf] + standard_name = instantaneous_atmosphere_updraft_convective_mass_flux + long_name = (updraft mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [qci_conv] standard_name = convective_cloud_condesate_after_rainout long_name = convective cloud condesate after rainout @@ -176,6 +248,14 @@ type = real kind = kind_phys intent = inout +[qs_save] + standard_name = snow_mixing_ratio_save + long_name = cloud snow mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [QC_BL] standard_name = subgrid_scale_cloud_liquid_water_mixing_ratio long_name = subgrid cloud water mixing ratio from PBL scheme @@ -248,6 +328,22 @@ type = real kind = kind_phys intent = inout +[clouds8] + standard_name = cloud_snow_water_path + long_name = cloud snow water path + units = g m-2 + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = inout +[clouds9] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow flake + units = um + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = inout [slmsk] standard_name = area_type long_name = landmask: sea/land/ice=0/1/2 From e76bc197014be97f98f8064c45b301c9439ab162 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Thu, 17 Feb 2022 19:41:42 +0000 Subject: [PATCH 05/37] moving ud_mf to TBD block in GFS_debug.F90 --- physics/GFS_debug.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 23d1be573..308376b10 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -593,6 +593,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvb' , Tbd%acvb) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvt' , Tbd%acvt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%hpbl' , Tbd%hpbl) + if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ud_mf' , Tbd%ud_mf) + end if if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtdtnp' , Tbd%dtdtnp) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtotprcp' , Tbd%dtotprcp) @@ -1331,7 +1334,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_ice ', Interstitial%tsurf_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_land ', Interstitial%tsurf_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_water ', Interstitial%tsurf_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ud_mf ', Interstitial%ud_mf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_ice ', Interstitial%uustar_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_land ', Interstitial%uustar_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_water ', Interstitial%uustar_water ) From c550ef81fb1f6d1117604e98e594c0768ab16c0f Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 22 Feb 2022 20:22:01 +0000 Subject: [PATCH 06/37] updated comments in SGSCloud_RadPre and Post --- physics/GFS_debug.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 23d1be573..308376b10 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -593,6 +593,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvb' , Tbd%acvb) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvt' , Tbd%acvt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%hpbl' , Tbd%hpbl) + if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ud_mf' , Tbd%ud_mf) + end if if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtdtnp' , Tbd%dtdtnp) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtotprcp' , Tbd%dtotprcp) @@ -1331,7 +1334,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_ice ', Interstitial%tsurf_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_land ', Interstitial%tsurf_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_water ', Interstitial%tsurf_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ud_mf ', Interstitial%ud_mf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_ice ', Interstitial%uustar_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_land ', Interstitial%uustar_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_water ', Interstitial%uustar_water ) From 4986cac9eaacd7375da3cf5f7c863a9f23fe2f40 Mon Sep 17 00:00:00 2001 From: "Christina.Holt" Date: Thu, 3 Mar 2022 22:46:16 +0000 Subject: [PATCH 07/37] A few corrections to the last merge commit. --- physics/module_MYNNPBL_wrapper.F90 | 2 +- physics/module_MYNNPBL_wrapper.meta | 66 +---------------------------- 2 files changed, 3 insertions(+), 65 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 234f8f6f4..9d720b9f8 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -281,7 +281,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dz, w, p, rho, th, qv, delp, & & RUBLTEN, RVBLTEN, RTHBLTEN, RQVBLTEN, & & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, & - & RQNWFABLTEN, RQNIFABLTEN, & + & RQNWFABLTEN, RQNIFABLTEN real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 5540d1384..60668ba88 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -7,68 +7,6 @@ [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_code - long_name = error code for error handling in CCPP - units = 1 - 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 [con_cp] standard_name = specific_heat_of_dry_air_at_constant_pressure long_name = specific heat of dry air at constant pressure @@ -204,8 +142,8 @@ intent = out [errflg] standard_name = ccpp_error_code - long_name = error flag for error handling in CCPP - units = flag + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out From b19488f1437e8b38cf9b38b5ac5bc7461811258c Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Tue, 8 Mar 2022 10:33:06 -0700 Subject: [PATCH 08/37] -Removes consistency check in GF, allows GF to run with different or no shallow scheme --- physics/cu_gf_driver.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 43e82a745..a9cecb5ce 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -50,14 +50,14 @@ subroutine cu_gf_driver_init(imfshalcnv, imfshalcnv_gf, imfdeepcnv, & ! end if ! *DH temporary - ! Consistency checks - if (.not. (imfshalcnv == imfshalcnv_gf .or. & - & imfdeepcnv == imfdeepcnv_gf)) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of', & - & ' convection is different from Grell-Freitas scheme' - errflg = 1 - return - end if + ! ! Consistency checks + ! if (.not. (imfshalcnv == imfshalcnv_gf .or. & + ! & imfdeepcnv == imfdeepcnv_gf)) then + ! write(errmsg,'(*(a))') 'Logic error: namelist choice of', & + ! & ' convection is different from Grell-Freitas scheme' + ! errflg = 1 + ! return + ! end if end subroutine cu_gf_driver_init From 1746cb2ce18cc0629b81aca8df1c0ee7c96e7fbe Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Wed, 9 Mar 2022 17:13:58 +0000 Subject: [PATCH 09/37] New codeowners for NOAA-GSL repo --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index f8492f59f..9000e999d 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @SamuelTrahanNOAA @DomHeinzeller +* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @hu5970 # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 022b3c410c32d5f48c9b2fc4bd7f20503862a074 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Wed, 9 Mar 2022 20:50:08 +0000 Subject: [PATCH 10/37] Add Li to the list, by Georg's request. --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 9000e999d..849f40aa7 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @hu5970 +* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @hu5970 @zhanglikate # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From fe2db0999941495e89070364ed37a084a7450f23 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Thu, 10 Mar 2022 02:47:53 +0000 Subject: [PATCH 11/37] No Ming Hu --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 849f40aa7..4742d1f7b 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @hu5970 @zhanglikate +* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @zhanglikate # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 942510fa63a9f4a21905acb4d295f19e83d42953 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 22 Mar 2022 14:20:12 +0000 Subject: [PATCH 12/37] removing added cloud fraction in precipitation for MYNN --- physics/GFS_rrtmg_pre.F90 | 17 +---------------- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 11 ++--------- 2 files changed, 3 insertions(+), 25 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 15845d4b3..db818c3b8 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -744,21 +744,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then - if (do_mynnedmf) then - do k=1,lm - k1 = k + kd - do i=1,im - if (tracer1(i,k1,ntrw)>1.0e-7 .OR. tracer1(i,k1,ntsw)>1.0e-7) then - ! GFDL cloud fraction - cldcov(i,k1) = tracer1(i,k1,ntclamt) - else - ! MYNN sub-grid cloud fraction - cldcov(i,k1) = clouds1(i,k1) - endif - enddo - enddo - else ! imfdeepcnv==imfdeepcnv_gf + if ((imfdeepcnv==imfdeepcnv_gf) .and. kdt>1) then do k=1,lm k1 = k + kd do i=1,im @@ -770,7 +756,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif enddo enddo - endif else ! GFDL cloud fraction cldcov(1:IM,1+kd:LM+kd) = tracer1(1:IM,1:LM,ntclamt) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index c6afd6ac0..d9d7c37f6 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -165,16 +165,9 @@ subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cld where(cld_reice .gt. radice_upr) cld_reice = radice_upr endif - ! Cloud-fraction. For mynnedmf, cld_frac is adjusted for precipitation here, otherwise - ! it passes through this interface. It is adjusted prior in sgscloudradpre. + ! Cloud-fraction. For mynnedmf, cld_frac is already defined in sgscloudradpre. if (do_mynnedmf .and. kdt .gt. 1) then - do iLay = 1, nLev - do iCol = 1, nCol - if (tracer(iCol,iLay,i_cldrain) > 1.0e-7 .OR. tracer(iCol,iLay,i_cldsnow)>1.0e-7) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - enddo - enddo + !already set in sgscloudradpre else cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) endif From 6176537497f70f19e691e706b6370aa2bb31a2df Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 22 Mar 2022 14:24:41 +0000 Subject: [PATCH 13/37] updating MYNN-EDMF SGS clouds and tweaks to the lateral entrainment in the MF scheme. --- physics/module_MYNNPBL_wrapper.F90 | 74 ++-- physics/module_MYNNPBL_wrapper.meta | 8 + physics/module_bl_mynn.F90 | 501 +++++++++++----------------- 3 files changed, 244 insertions(+), 339 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 9d720b9f8..d9e53f9d3 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -132,7 +132,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dtsfc_cpl,dqsfc_cpl, & & recmol, & & qke,qke_adv,Tsq,Qsq,Cov, & - & el_pbl,sh3d,exch_h,exch_m, & + & el_pbl,sh3d,sm3d,exch_h,exch_m, & & dqke,qwt,qshear,qbuoy,qdiss, & & Pblh,kpbl, & & qc_bl,qi_bl,cldfra_bl, & @@ -179,10 +179,10 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: rrfs_smoke, rrfs_smoke, fire_turb + !logical, intent(in) :: mix_chem, fire_turb !integer, intent(in) :: nchem, ndvel, kdvel !for testing only: - logical, parameter :: rrfs_smoke=.false., mix_chem=.false., fire_turb=.false. + logical, parameter :: mix_chem=.false., fire_turb=.false. integer, parameter :: nchem=2, ndvel=2, kdvel=1 ! NAMELIST OPTIONS (INPUT): @@ -248,7 +248,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc real(kind=kind_phys), dimension(:,:), intent(inout) :: & - & qke, qke_adv, EL_PBL, Sh3D, & + & qke, qke_adv, EL_PBL, Sh3D, Sm3D, & & qc_bl, qi_bl, cldfra_bl !These 10 arrays are only allocated when bl_mynn_output > 0 real(kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -366,7 +366,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FRP = 0. EMIS_ANT_NO = 0. vdep = 0. ! hli for chem dry deposition, 0 temporarily - if (rrfs_smoke) then + if (mix_chem) then allocate ( chem3d(im,levs,nchem) ) do k=1,levs do i=1,im @@ -697,11 +697,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol, & & wspd=wspd,uoce=uoce,voce=voce,vdfg=vdfg, & !input & qke=QKE,qke_adv=qke_adv, & !output - & bl_mynn_tkeadvect=bl_mynn_tkeadvect,sh3d=Sh3d, & + & sh3d=Sh3d,sm3d=Sm3d, & !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, & !----- @@ -712,36 +711,37 @@ SUBROUTINE mynnedmf_wrapper_run( & & RQNIBLTEN=rqniblten,RQNWFABLTEN=RQNWFABLTEN, & !output & RQNIFABLTEN=RQNIFABLTEN,dozone=dqdt_ozone, & !output & EXCH_H=exch_h,EXCH_M=exch_m, & !output - & pblh=pblh,KPBL=KPBL & !output - & ,el_pbl=el_pbl & !output - & ,dqke=dqke & !output - & ,qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS & !output - & ,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=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 - & ,bl_mynn_output=bl_mynn_output & !input parameter - & ,bl_mynn_cloudmix=bl_mynn_cloudmix & !input parameter - & ,bl_mynn_mixqt=bl_mynn_mixqt & !input parameter - & ,edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt & !output - & ,edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc &!output - & ,sub_thl3D=sub_thl,sub_sqv3D=sub_sqv & - & ,det_thl3D=det_thl,det_sqv3D=det_sqv & - & ,nupdraft=nupdraft,maxMF=maxMF & !output - & ,ktop_plume=ktop_plume & !output - & ,spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl & !input - & ,RTHRATEN=htrlw & !input - & ,FLAG_QI=flag_qi,FLAG_QNI=flag_qni & !input - & ,FLAG_QC=flag_qc,FLAG_QNC=flag_qnc & !input - & ,FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA & !input - & ,IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs & !input - & ,IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs & !input - & ,ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input + & pblh=pblh,KPBL=KPBL, & !output + & el_pbl=el_pbl, & !output + & dqke=dqke, & !output + & qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS, & !output + & bl_mynn_tkeadvect=bl_mynn_tkeadvect, & + & 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=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 + & bl_mynn_output=bl_mynn_output, & !input parameter + & bl_mynn_cloudmix=bl_mynn_cloudmix, & !input parameter + & bl_mynn_mixqt=bl_mynn_mixqt, & !input parameter + & edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt, & !output + & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,&!output + & sub_thl3D=sub_thl,sub_sqv3D=sub_sqv, & + & det_thl3D=det_thl,det_sqv3D=det_sqv, & + & nupdraft=nupdraft,maxMF=maxMF, & !output + & ktop_plume=ktop_plume, & !output + & spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input + & RTHRATEN=htrlw, & !input + & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input + & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input + & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input + & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input + & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input + & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input ! POST MYNN (INTERSTITIAL) WORK: diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 60668ba88..658c80100 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -764,6 +764,14 @@ type = real kind = kind_phys intent = inout +[Sm3D] + standard_name = stability_function_for_momentum + long_name = stability function for momentum + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [exch_h] standard_name = atmosphere_heat_diffusivity_for_mynnpbl long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 36ff3ebf7..292d5aa18 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -216,7 +216,7 @@ ! Misc small-impact bugfixes: ! 1) dz was incorrectly indexed in mym_condensation ! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.3.2 / CCPP +! v4.4 / 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) @@ -228,9 +228,8 @@ ! Important bug fixes for mixing of chemical species. ! Addition of pressure-gradient effects on updraft momentum transport. ! Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0 -! 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. +! Addition of higher-order moments for sigma when using +! bl_mynn_cloudpdf = 2 (Chab-Becht). ! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. ! @@ -322,7 +321,7 @@ MODULE module_bl_mynn IMPLICIT NONE - +!get rid INTEGER , PARAMETER :: param_first_scalar = 1, & & p_qc = 2, & & p_qr = 0, & @@ -332,23 +331,8 @@ MODULE module_bl_mynn & p_qnc= 0, & & p_qni= 0 -!END FV3 CONSTANTS -!==================================================================== -!WRF CONSTANTS -! USE module_model_constants, only: & -! &karman, grav, p1000mb, & -! &cp, r_d, r_v, rcp, xlv, xlf, xls, & -! &svp1, svp2, svp3, p608, 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 -! -! IMPLICIT NONE -! -!END WRF CONSTANTS !=================================================================== -! From here on, these are used for any model +! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & cphh_st=5.0, cphh_unst=16.0 @@ -476,11 +460,10 @@ SUBROUTINE mynn_bl_driver( & &uoce,voce, & !ocean current &vdfg, & !Katata-added for fog dep &Qke,qke_adv, & - &bl_mynn_tkeadvect,sh3d, & + &sh3d,sm3d, & &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 @@ -488,15 +471,18 @@ SUBROUTINE mynn_bl_driver( & &RUBLTEN,RVBLTEN,RTHBLTEN, & &RQVBLTEN,RQCBLTEN,RQIBLTEN, & &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN,DOZONE, & + &RQNWFABLTEN,RQNIFABLTEN, & + &DOZONE, & &exch_h,exch_m, & &Pblh,kpbl, & &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & !TKE BUDGET + &dqke,qWT,qSHEAR,qBUOY,qDISS, & + &qc_bl,qi_bl,cldfra_bl, & + &bl_mynn_tkeadvect, & &bl_mynn_tkebudget, & &bl_mynn_cloudpdf, & &bl_mynn_mixlength, & - &icloud_bl,qc_bl,qi_bl,cldfra_bl,& + &icloud_bl, & &closure, & &bl_mynn_edmf, & &bl_mynn_edmf_mom, & @@ -541,7 +527,7 @@ SUBROUTINE mynn_bl_driver( & LOGICAL, INTENT(IN) :: mix_chem,fire_turb - INTEGER,INTENT(in) :: & + INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE @@ -558,37 +544,32 @@ SUBROUTINE mynn_bl_driver( & ! = 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,& + 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)::& + 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,& + REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust, & &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &Qke,Tsq,Qsq,Cov,qke_adv !ACF for QKE advection + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + &Qke,Tsq,Qsq,Cov,qke_adv - 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, & &RQNWFABLTEN,RQNIFABLTEN REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & &exch_h,exch_m !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, & + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D ! REAL, DIMENSION(IMS:IME,KMS:KME) :: & @@ -607,13 +588,13 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &el_pbl - REAL, DIMENSION(:,:), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), optional, 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 + REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(IMS:IME,KMS:KME) :: Sh3D + REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl @@ -622,40 +603,42 @@ SUBROUTINE mynn_bl_driver( & ! 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 - - REAL, DIMENSION(KTS:KTE ,nchem) :: chem1 - REAL, DIMENSION(KTS:KTE+1,nchem) :: s_awchem1 - REAL, DIMENSION(its:ite) :: vd1 + REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d + REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep + REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO + !local + REAL, DIMENSION(kts:kte ,nchem) :: chem1 + REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 + REAL, DIMENSION(ndvel) :: vd1 INTEGER :: ic !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, & + &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 + 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 !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, & + 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,& + 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,& + REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw @@ -670,10 +653,9 @@ SUBROUTINE mynn_bl_driver( & LOGICAL :: INITIALIZE_QKE ! Stochastic fields - INTEGER, INTENT(IN) :: spp_pbl - !GJF: this array must be assumed-shape since it's conditionally-allocated - REAL, DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col + INTEGER, INTENT(IN) ::spp_pbl + REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) ::rstoch_col ! Substepping TKE INTEGER :: nsub @@ -702,11 +684,6 @@ SUBROUTINE mynn_bl_driver( & JMD=(JMS+JME)/2 !*** End debugging -!WRF -! JTF=MIN0(JTE,JDE-1) -! ITF=MIN0(ITE,IDE-1) -! KTF=MIN0(KTE,KDE-1) -!FV3 JTF=JTE ITF=ITE KTF=KTE @@ -758,6 +735,7 @@ SUBROUTINE mynn_bl_driver( & if (.not.restart .or. .not.cycling) THEN Sh3D(its:ite,kts:kte)=0. + Sm3D(its:ite,kts:kte)=0. el_pbl(its:ite,kts:kte)=0. tsq(its:ite,kts:kte)=0. qsq(its:ite,kts:kte)=0. @@ -882,6 +860,7 @@ SUBROUTINE mynn_bl_driver( & ENDIF el(k)=el_pbl(i,k) sh(k)=Sh3D(i,k) + sm(k)=Sm3D(i,k) tsq1(k)=tsq(i,k) qsq1(k)=qsq(i,k) cov1(k)=cov(i,k) @@ -933,6 +912,7 @@ SUBROUTINE mynn_bl_driver( & DO k=KTS,KTE !KTF el_pbl(i,k)=el(k) sh3d(i,k)=sh(k) + sm3d(i,k)=sm(k) qke(i,k)=qke1(k) tsq(i,k)=tsq1(k) qsq(i,k)=qsq1(k) @@ -1078,7 +1058,8 @@ SUBROUTINE mynn_bl_driver( & ENDIF el(k) = el_pbl(i,k) qke1(k)=qke(i,k) - sh(k) = sh3d(i,k) + sh(k) =sh3d(i,k) + sm(k) =sm3d(i,k) tsq1(k)=tsq(i,k) qsq1(k)=qsq(i,k) cov1(k)=cov(i,k) @@ -1134,7 +1115,6 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !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???? @@ -1160,7 +1140,6 @@ SUBROUTINE mynn_bl_driver( & enddo enddo ENDIF - ENDIF zw(kte+1)=zw(kte)+dz(i,kte) !EDMF @@ -1383,8 +1362,9 @@ SUBROUTINE mynn_bl_driver( & 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.)) + diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + ! Limit heating above 100 mb: + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) ENDDO diss_heat(kte) = 0. else @@ -1517,7 +1497,7 @@ SUBROUTINE mynn_bl_driver( & qsq(i,k)=qsq1(k) cov(i,k)=cov1(k) sh3d(i,k)=sh(k) - + sm3d(i,k)=sm(k) ENDDO !end-k IF ( bl_mynn_tkebudget ) THEN @@ -2108,11 +2088,11 @@ SUBROUTINE mym_length ( & CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 - alp1 = 0.23 + alp1 = 0.21 alp2 = 1.0 alp3 = 5.0 alp4 = 100. - alp5 = 0.2 + alp5 = 0.3 ! 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. @@ -2194,7 +2174,7 @@ SUBROUTINE mym_length ( & alp2 = 0.3 alp3 = 1.5 alp4 = 5.0 - alp5 = 0.2 + alp5 = 0.3 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth @@ -2246,6 +2226,7 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN + alp2 = 0.3 + 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) bv = SQRT( gtr*dtv(k) ) !elb = alp2*qkw(k) / bv & ! formulation, ! & *( 1.0 + alp3/alp2*& ! except keep @@ -2876,7 +2857,7 @@ SUBROUTINE mym_turbulence ( & REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,& - sm_pbl,sh_pbl,zi2,wt + sm_pbl,sh_pbl,zi2,wt,slht,wtpr DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv @@ -2885,7 +2866,7 @@ SUBROUTINE mym_turbulence ( & ! Stochastic INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum + REAL :: Prnum, Prlim REAL, PARAMETER :: Prlimit = 5.0 @@ -2972,11 +2953,10 @@ SUBROUTINE mym_turbulence ( & ! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** -!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact +! 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 + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) IF ( q3sq .LT. q2sq ) THEN !Apply Helfand & Labraga mod @@ -3084,6 +3064,9 @@ SUBROUTINE mym_turbulence ( & !IF ( sm(k) > sm25max ) sm(k) = sm25max !IF ( sm(k) < sm25min ) sm(k) = sm25min !sm(k) = Prnum*sh(k) + slht = zi*0.1 + wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer + Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit sm(k) = MIN(sm(k), Prlimit*Sh(k)) ! ** Level 3 : start ** @@ -3236,10 +3219,9 @@ SUBROUTINE mym_turbulence ( & END IF ! ! Add min background stability function (diffusivity) within model levels -! with active plumes and low cloud fractions. +! with active plumes and clouds. 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 * & @@ -3249,8 +3231,8 @@ SUBROUTINE mym_turbulence ( & 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) ) + sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) ) + sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) ) ENDIF ! elq = el(k)*qkw(k) @@ -3625,7 +3607,7 @@ SUBROUTINE mym_predict (kts,kte, & DO k=kts,kte !qsq(k)=d(k-kts+1) - qsq(k)=MAX(x(k),1e-12) + qsq(k)=MAX(x(k),1e-17) ENDDO ELSE !level 2.5 - use level 2 diagnostic @@ -3781,8 +3763,8 @@ END SUBROUTINE mym_predict ! 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 +! Work arrays/variables: +! qmq : 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 @@ -3830,15 +3812,15 @@ SUBROUTINE mym_condensation (kts,kte, & REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm - REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,RH + REAL, DIMENSION(kts:kte) :: 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 :: 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 + REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,& + &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,& + &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& + &qmq,qsat_tk INTEGER :: i,j,k REAL :: erf @@ -3850,7 +3832,6 @@ SUBROUTINE mym_condensation (kts,kte, & !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 !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -3917,11 +3898,11 @@ SUBROUTINE mym_condensation (kts,kte, & 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 + qmq = qw(k) -qsl !ORIGINAL STANDARD DEVIATION sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq(k) / sgm(k) + q1(k) = qmq / sgm(k) !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) @@ -3979,8 +3960,8 @@ SUBROUTINE mym_condensation (kts,kte, & 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) + qmq = qw(k) -qsl + q1(k) = qmq / sgm(k) cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) !now compute estimated lwc for PBL scheme's use @@ -4016,144 +3997,54 @@ SUBROUTINE mym_condensation (kts,kte, & CASE (2, -2) - 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) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - 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" + !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 + zagl = zagl + dz(k) + t = th(k)*exner(k) + + xl = xl_blend(t) ! obtain latent heat + qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p + rh(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsat_tk)),0.001) + + !dqw/dT: Clausius-Clapeyron + dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) - 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))) + rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) + ! 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" - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - 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. )) - - !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. - - ! 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. - - 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 - - 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 + !This form of qmq (the numerator of Q1) no longer uses the a(k) factor + qmq = qw_pert - qsat_tk ! saturation deficit/excess; - else + !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_tk*0.666 ) !500 ) + sgm(k) = MAX( sgm(k), qsat_tk*0.040 ) !Note: 0.02 results in SWDOWN similar + !to the first-order version of sigma + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + + !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)))) - !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) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - 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" - - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - - !This form of qmq (the numerator of Q1) no longer uses the a(k) factor - qmq(k) = qw_pert - qsat_tl ! saturation deficit/excess; - - !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 - - !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)))) - - END DO - - endif !end sig_order option + END DO ! Specify hydrometeors ! JAYMES- this option added 8 May 2015 @@ -4172,10 +4063,6 @@ SUBROUTINE mym_condensation (kts,kte, & 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 @@ -4276,11 +4163,14 @@ SUBROUTINE mym_condensation (kts,kte, & ! 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)/ & + !fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) + fac_damp = min(zagl * 0.01, 1.0) !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 + !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.22 )**2 + cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 + !cld_factor = 1.0 cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) ENDDO @@ -5300,25 +5190,27 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! sqv, sqc, sqi, thl, & ! dqv, dqc, dqi, dth ) - 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 + if (debug_code) then + 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*,"Huge wind speed: 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(kts) + 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 - 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 #ifdef HARDCODE_VERTICAL @@ -6025,7 +5917,7 @@ SUBROUTINE DMP_mf( & 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, & - Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters REAL,PARAMETER :: & @@ -6066,7 +5958,7 @@ SUBROUTINE DMP_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,& + REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,qsat_tk,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf @@ -6250,13 +6142,14 @@ SUBROUTINE DMP_mf( & !Criteria (2) maxwidth = 1.1*PBLH ! Criteria (3) - maxwidth = MIN(maxwidth,0.333*cloud_base) + maxwidth = MIN(maxwidth,0.5*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) - 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.) + !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) else !water width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.) endif @@ -6264,7 +6157,7 @@ SUBROUTINE DMP_mf( & ! Convert maxwidth to number of plumes NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) - !Initialize values: + !Initialize values for 2d output fields: ktop = 0 ztop = 0.0 maxmf= 0.0 @@ -6286,7 +6179,8 @@ SUBROUTINE DMP_mf( & ! 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 + !acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5 + acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 else !water acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 endif @@ -6404,16 +6298,17 @@ SUBROUTINE DMP_mf( & DO k=KTS+1,KTE-1 !Entrainment from Tian and Kuang (2016) !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) - !wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh - !ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) + wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh + ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) !Entrainment from Negggers (2015, JAMES) !ENT(k,i) = 0.02*l**-0.35 - 0.0009 - ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity + !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity + !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+" !Minimum background entrainment ENT(k,i) = max(ENT(k,i),0.0003) - ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang + !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang !JOE - increase entrainment for plumes extending very high. IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN @@ -6425,18 +6320,19 @@ SUBROUTINE DMP_mf( & ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - ! Define environment U & V at the model interface levels - Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + ! Define environment U & V at the model interface levels + Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) ! Linear entrainment: EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) + EntExm= EntExp*0.3333 !reduce entrainment for momentum QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp - Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp + dxsa*pgfac*(Uk - Ukm1) - Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + dxsa*pgfac*(Vk - Vkm1) + Un =UPU(k-1,I) *(1.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1) + Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + dxsa*pgfac*(Vk - Vkm1) QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp @@ -6876,11 +6772,10 @@ SUBROUTINE DMP_mf( & 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 - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + xl = xl_blend(tk(k)) ! obtain blended heat capacity + qsat_tk = qsat_blend(tk(k),p(k)) ! get saturation water vapor mixing ratio + ! at t and p + rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp) ! CB02, Eqn. 4 cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" @@ -6896,8 +6791,7 @@ SUBROUTINE DMP_mf( & ! conversion is neglected here. qww = 1.+0.61*qt(k) alpha = 0.61*pt - t = TH(k)*exner(k) - beta = pt*xl/(t*cp) - 1.61*pt + beta = pt*xl/(tk(k)*cp) - 1.61*pt !Buoyancy flux terms have been moved to the end of this section... !Now calculate convective component of the cloud fraction: @@ -6907,20 +6801,24 @@ SUBROUTINE DMP_mf( & f = 1.0 endif - sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & - & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) - sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - sigq = MAX(sigq, 1.0E-6) + !CB form: + !sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & + ! & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components + !Per S.DeRoode 2009? + sigq = 10. * edmf_a(k) * (edmf_qt(k)-qt(k)) + + sigq = MAX(sigq, 1.0E-6) - qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; + qmq = a * (qt(k) - qsat_tk) ! 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: env qt=",qt(k)," qsat=",qsat_tk + ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k) + ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k) ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) !ENDIF @@ -6941,7 +6839,7 @@ SUBROUTINE DMP_mf( & !The mixing ratios from the stratus component are not well !estimated in shallow-cumulus regimes. Ensure stratus clouds !have mixing ratio similar to cumulus - QCs = MIN(MAX(qc_bl1d(k), 0.5*qc_mf), 5E-4) + QCs = MAX(qc_bl1d(k), 0.5*qc_mf) qc_bl1d(k) = (qc_mf*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) ELSE !cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) @@ -6951,7 +6849,7 @@ SUBROUTINE DMP_mf( & cldfra_bl1d(k)=Ac_mf + Ac_strat qc_mf = QCp !Ensure stratus clouds have mixing ratio similar to cumulus - QCs = MIN(MAX(qc_bl1d(k), 0.5*qc_mf), 5E-4) + QCs = MAX(qc_bl1d(k), 0.5*qc_mf) qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) ENDIF ELSE @@ -7197,7 +7095,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,& + REAL :: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters @@ -7669,7 +7567,6 @@ FUNCTION xl_blend(t) 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 From f7a9d915269de609bf2597e00f262d752bdf0e94 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Thu, 24 Mar 2022 15:56:20 +0000 Subject: [PATCH 14/37] GWD, LSM and MYNN physics updates from RRFS_dev branch --- physics/GFS_surface_composites.F90 | 31 +++++++++++++++++------ physics/GFS_surface_composites.meta | 36 ++++++++++++++++++++++++--- physics/drag_suite.F90 | 38 ++++++++++------------------- physics/module_sf_mynn.F90 | 2 +- physics/module_sf_ruclsm.F90 | 3 ++- 5 files changed, 73 insertions(+), 37 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 510b3f427..f44df5890 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -27,8 +27,9 @@ end subroutine GFS_surface_composites_pre_finalize !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, frac_grid, & - flag_cice, cplflx, cplice, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & + subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_cold_start, lkm, frac_grid, & + flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & @@ -40,10 +41,11 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra implicit none ! Interface variables - integer, intent(in ) :: im, lkm, kdt - logical, intent(in ) :: flag_init, flag_restart, frac_grid, cplflx, cplice, cplwav2atm + integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc + logical, intent(in ) :: flag_init, lsm_cold_start, frac_grid, cplflx, cplice, cplwav2atm logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet + real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland @@ -201,12 +203,13 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif endif enddo - endif + endif ! frac_grid do i=1,im tprcp_wat(i) = tprcp(i) tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) + if (wet(i)) then ! Water uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) @@ -219,7 +222,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) - weasd_lnd(i) = weasd(i) + if(lsm /= lsm_ruc) weasd_lnd(i) = weasd(i) tsurf_lnd(i) = tsfcl(i) ! DH* else @@ -230,7 +233,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) - weasd_ice(i) = weasd(i) + if(lsm /= lsm_ruc) weasd_ice(i) = weasd(i) tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero @@ -279,7 +282,17 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif enddo else + if(lsm /= lsm_ruc) then ! do not do snow initialization with RUC lsm do i=1,im + !-- print ice point + !if ( (xlon_d(i) > 298.6) .and. (xlon_d(i) < 298.7) .and. & + ! (xlat_d(i) > 68.6 ) .and. (xlat_d(i) < 68.7 )) then + ! print *,'Composit weasd_ice(i),snowd_ice',kdt,i,xlat_d(i),xlon_d(i),weasd_ice(i),snowd_ice(i) + !endif + !if ( (xlon_d(i) > 284.35) .and. (xlon_d(i) < 284.6) .and. & + ! (xlat_d(i) > 41.0 ) .and. (xlat_d(i) < 41.2 )) then + ! print *,'Composit2 weasd_lnd(i),snowd_lnd',kdt,i,xlat_d(i),xlon_d(i),weasd_lnd(i),snowd_lnd(i) + !endif if (icy(i)) then if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then snowd_lnd(i) = zero @@ -290,6 +303,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif endif enddo + endif ! lsm/=lsm_ruc endif ! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) @@ -644,6 +658,7 @@ subroutine GFS_surface_composites_post_run ( do i=1,im if (islmsk(i) == 1) then + !-- land zorl(i) = zorll(i) cd(i) = cd_lnd(i) cdq(i) = cdq_lnd(i) @@ -669,6 +684,7 @@ subroutine GFS_surface_composites_post_run ( hice(i) = zero cice(i) = zero elseif (islmsk(i) == 0) then + !-- water zorl(i) = zorlo(i) cd(i) = cd_wat(i) cdq(i) = cdq_wat(i) @@ -695,6 +711,7 @@ subroutine GFS_surface_composites_post_run ( hice(i) = zero cice(i) = zero else ! islmsk(i) == 2 + !-- ice zorl(i) = zorli(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 89048e487..40f0c940c 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -14,6 +14,22 @@ dimensions = () type = integer intent = in +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [flag_init] standard_name = flag_for_first_timestep long_name = flag signaling first time step for time integration loop @@ -21,9 +37,9 @@ dimensions = () type = logical intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started units = flag dimensions = () type = logical @@ -70,6 +86,20 @@ dimensions = () type = logical intent = in +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_ruc] + standard_name = identifier_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [landfrac] standard_name = land_area_fraction long_name = fraction of horizontal grid area occupied by land diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 7fea98b13..fe9095210 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -589,17 +589,8 @@ subroutine drag_suite_run( & endif enddo -do i=1,im - if ( dx(i) .ge. dxmax_ss ) then - ss_taper(i) = 1. - else - if ( dx(i) .le. dxmin_ss) then - ss_taper(i) = 0. - else - ss_taper(i) = dxmax_ss * (1. - dxmin_ss/dx(i))/(dxmax_ss-dxmin_ss) - endif - endif -enddo +! Remove ss_tapering +ss_taper(:) = 1. ! SPP, if spp_gwd is 0, no perturbations are applied. if ( spp_gwd==1 ) then @@ -986,13 +977,11 @@ subroutine drag_suite_run( & enddo if((xland(i)-1.5).le.0. .and. 2.*varss_stoch(i).le.hpbl(i))then if(br1(i).gt.0. .and. thvx(i,kpbl2)-thvx(i,kts) > 0.)then - cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) ! WRF + ! Modify xlinv to represent wave number of "typical" small-scale topography ! cleff_ss = 3. * max(dx(i),cleff_ss) ! cleff_ss = 10. * max(dxmax_ss,cleff_ss) - cleff_ss = 0.1 * max(dxmax_ss,cleff_ss) ! WRF ! cleff_ss = 0.1 * 12000. - coefm_ss(i) = (1. + olss(i)) ** (oass(i)+1.) - xlinv(i) = coefm_ss(i) / cleff_ss + xlinv(i) = 0.001*pi ! 2km horizontal wavelength !govrth(i)=g/(0.5*(thvx(i,kpbl(i))+thvx(i,kts))) govrth(i)=g/(0.5*(thvx(i,kpbl2)+thvx(i,kts))) !XNBV=sqrt(govrth(i)*(thvx(i,kpbl(i))-thvx(i,kts))/hpbl(i)) @@ -1003,8 +992,8 @@ subroutine drag_suite_run( & !tauwavex0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*u1(i,kpbl(i)) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,kpbl2) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) - var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavex0=var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) @@ -1018,8 +1007,8 @@ subroutine drag_suite_run( & !tauwavey0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*v1(i,kpbl(i)) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,kpbl2) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) - var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & - MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavey0=var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) @@ -1083,17 +1072,16 @@ subroutine drag_suite_run( & IF ((xland(i)-1.5) .le. 0.) then !(IH*kflt**n1)**-1 = (0.00102*0.00035**-1.9)**-1 = 0.00026615161 - var_temp = MIN(varss_stoch(i),varmax_fd_stoch(i)) + & - MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch(i))) - var_temp = MIN(var_temp, 250.) + ! Remove limit on varss_stoch + var_temp = varss_stoch(i) + !var_temp = MIN(var_temp, 250.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 ! a1=0.00026615161*(0.5*varss(i))**2 ! k1**(n1-n2) = 0.003**(-1.9 - -2.8) = 0.003**0.9 = 0.005363 a2=a1*0.005363 - ! Revise e-folding height based on PBL height and topographic std. dev. -- M. Toy 3/12/2018 - H_efold = max(2*varss_stoch(i),hpbl(i)) - H_efold = min(H_efold,1500.) + ! Beljaars H_efold + H_efold = 1500. DO k=kts,km wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 5f227750a..65e83c93d 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -112,7 +112,7 @@ MODULE module_sf_mynn !1: check input !2: everything - heavy I/O LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .false. !shouldn't need compute + LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute ! these in FV3. They will be written over anyway. ! Computing the fluxes here is leftover from the WRF world. diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index b39610bc8..01e9c1100 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2595,7 +2595,8 @@ SUBROUTINE SOIL (debug_print, & ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. !fc=max(qmin,ref*0.5) - fc=max(qmin,ref*0.7) + !fc=max(qmin,ref*0.7) + fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then soilres = 1. From 9b783f400f656f981ce435f8cb988c18ab5682df Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 25 Mar 2022 22:07:11 +0000 Subject: [PATCH 15/37] Bug fix for COARE3.5 (not used by default) and move some parameters to namelist options --- physics/module_MYNNSFC_wrapper.F90 | 31 ++++++++++------------------- physics/module_MYNNSFC_wrapper.meta | 28 ++++++++++++++++++++++++++ physics/module_sf_mynn.F90 | 21 +++++++++---------- 3 files changed, 49 insertions(+), 31 deletions(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 150a66472..52a33f555 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -62,6 +62,9 @@ SUBROUTINE mynnsfc_wrapper_run( & & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) & redrag,sfc_z0_type, & !intent(in) + & isftcflx,iz0tlnd, & !intent(in) + & sfclay_compute_flux, & !intent(in) + & sfclay_compute_diag, & !intent(in) & delt,dx, & & u, v, t3d, qvsh, qc, prsl, phii, & & exner, ps, PBLH, slmsk, & @@ -98,19 +101,6 @@ SUBROUTINE mynnsfc_wrapper_run( & ! should be moved to inside the mynn: use machine , only : kind_phys -! 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 - ! USE module_sf_mynn, only : SFCLAY_mynn !tgs - info on iterations: ! flag_iter- logical, execution or not (im) @@ -143,11 +133,9 @@ SUBROUTINE mynnsfc_wrapper_run( & integer, intent(out) :: errflg !MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & - & isftcflx = 0, & !control: 0 - & iz0tlnd = 0, & !control: 0 - & isfflx = 1 - + INTEGER, PARAMETER :: isfflx = 1 + logical, intent(in) :: sfclay_compute_flux,sfclay_compute_diag + integer, intent(in) :: isftcflx,iz0tlnd integer, intent(in) :: im, levs integer, intent(in) :: iter, itimestep, lsm, lsm_ruc logical, dimension(:), intent(in) :: flag_iter @@ -311,9 +299,10 @@ SUBROUTINE mynnsfc_wrapper_run( & EP1=ep_1,EP2=ep_2,KARMAN=karman, & ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,LSM_RUC=lsm_ruc, & iz0tlnd=iz0tlnd,psi_opt=psi_opt, & - & sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) - & z0pert=z0pert,ztpert=ztpert, & !intent(in) - & redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) + compute_flux=sfclay_compute_flux,compute_diag=sfclay_compute_diag,& + sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) + z0pert=z0pert,ztpert=ztpert, & !intent(in) + redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index 4e73504d7..5d30d71f3 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -157,6 +157,34 @@ dimensions = () type = integer intent = in +[isftcflx] + standard_name = flag_for_thermal_roughness_lengths_over_water_in_mynnsfclay + long_name = flag for thermal roughness lengths over water in mynnsfclay + units = flag + dimensions = () + type = integer + intent = in +[iz0tlnd] + standard_name = flag_for_thermal_roughness_lengths_over_land_in_mynnsfclay + long_name = flag for thermal roughness lengths over land in mynnsfclay + units = flag + dimensions = () + type = integer + intent = in +[sfclay_compute_flux] + standard_name = flag_for_computing_surface_scalar_fluxes_in_mynnsfclay + long_name = flag for computing surface scalar fluxes in mynnsfclay + units = flag + dimensions = () + type = logical + intent = in +[sfclay_compute_diag] + standard_name = flag_for_computing_surface_diagnostics_in_mynnsfclay + long_name = flag for computing surface diagnostics in mynnsfclay + units = flag + dimensions = () + type = logical + intent = in [delt] standard_name = timestep_for_physics long_name = time step for physics diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 65e83c93d..31335d3a9 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -111,10 +111,6 @@ MODULE module_sf_mynn INTEGER, PARAMETER :: debug_code = 0 !0: no extra ouput !1: check input !2: everything - heavy I/O - LOGICAL, PARAMETER :: compute_diag = .false. - LOGICAL, PARAMETER :: compute_flux = .true. !shouldn't need compute - ! these in FV3. They will be written over anyway. - ! Computing the fluxes here is leftover from the WRF world. REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab @@ -132,10 +128,11 @@ SUBROUTINE SFCLAY_mynn( & CP,G,ROVCP,R,XLV, & !in SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in ISFFLX,isftcflx,lsm,lsm_ruc, & !in + compute_flux,compute_diag, & !in iz0tlnd,psi_opt, & !in - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & !intent(in) - & redrag,sfc_z0_type, & !intent(in) + sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + z0pert,ztpert, & !intent(in) + redrag,sfc_z0_type, & !intent(in) itimestep,iter,flag_iter, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -273,8 +270,9 @@ SUBROUTINE SFCLAY_mynn( & REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX !NAMELIST/CONFIGURATION OPTIONS: INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + logical, intent(in) :: compute_flux,compute_diag integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -441,6 +439,7 @@ SUBROUTINE SFCLAY_mynn( & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & + compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) @@ -488,6 +487,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & + compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) @@ -543,6 +543,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !----------------------------- INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND + logical, intent(in) :: compute_flux,compute_diag INTEGER, INTENT(IN) :: spp_sfc, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean @@ -2418,7 +2419,7 @@ SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) REAL, INTENT(IN) :: ustar, visc, wsp10, zu REAL, INTENT(OUT) :: Z_0 REAL, PARAMETER :: G=9.81 - REAL, PARAMETER :: m=0.017, b=-0.005 + REAL, PARAMETER :: m=0.0017, b=-0.005 REAL :: CZC ! variable charnock "constant" REAL :: wsp10m ! logarithmically calculated 10 m From 58917678aceb22b8793bf1fd5da811e40c282c4e Mon Sep 17 00:00:00 2001 From: haiqinli <38666296+haiqinli@users.noreply.github.com> Date: Fri, 8 Apr 2022 12:24:22 -0600 Subject: [PATCH 16/37] Create readme --- smoke/readme | 1 + 1 file changed, 1 insertion(+) create mode 100644 smoke/readme diff --git a/smoke/readme b/smoke/readme new file mode 100644 index 000000000..e8027d7fa --- /dev/null +++ b/smoke/readme @@ -0,0 +1 @@ +the smoke directory From 9137366b24fac03809ece6c1c7aeee58a673dd0b Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 8 Apr 2022 18:28:52 +0000 Subject: [PATCH 17/37] "add smoke subroutines" --- smoke/dep_dry_gocart_mod.F90 | 298 ++++ smoke/dep_dry_mod.F90 | 300 ++++ smoke/dep_simple_mod.F90 | 763 +++++++++ smoke/dep_vertmx_mod.F90 | 209 +++ smoke/dep_wet_ls_mod.F90 | 565 +++++++ smoke/dust_data_mod.F90 | 108 ++ smoke/dust_fengsha_mod.F90 | 598 +++++++ smoke/module_add_emiss_burn.F90 | 223 +++ smoke/module_plumerise1.F90 | 211 +++ smoke/module_smoke_plumerise.F90 | 2345 +++++++++++++++++++++++++++ smoke/module_zero_plumegen_coms.F90 | 192 +++ smoke/plume_data_mod.F90 | 49 + smoke/readme | 1 - smoke/rrfs_smoke_config.F90 | 125 ++ smoke/rrfs_smoke_data.F90 | 644 ++++++++ smoke/rrfs_smoke_lsdep_wrapper.F90 | 338 ++++ smoke/rrfs_smoke_lsdep_wrapper.meta | 210 +++ smoke/rrfs_smoke_postpbl.F90 | 73 + smoke/rrfs_smoke_postpbl.meta | 85 + smoke/rrfs_smoke_wrapper.F90 | 762 +++++++++ smoke/rrfs_smoke_wrapper.meta | 632 ++++++++ smoke/seas_data_mod.F90 | 18 + smoke/seas_mod.F90 | 429 +++++ smoke/seas_ngac_mod.F90 | 188 +++ 24 files changed, 9365 insertions(+), 1 deletion(-) create mode 100755 smoke/dep_dry_gocart_mod.F90 create mode 100755 smoke/dep_dry_mod.F90 create mode 100755 smoke/dep_simple_mod.F90 create mode 100755 smoke/dep_vertmx_mod.F90 create mode 100755 smoke/dep_wet_ls_mod.F90 create mode 100755 smoke/dust_data_mod.F90 create mode 100755 smoke/dust_fengsha_mod.F90 create mode 100755 smoke/module_add_emiss_burn.F90 create mode 100755 smoke/module_plumerise1.F90 create mode 100755 smoke/module_smoke_plumerise.F90 create mode 100755 smoke/module_zero_plumegen_coms.F90 create mode 100755 smoke/plume_data_mod.F90 delete mode 100644 smoke/readme create mode 100755 smoke/rrfs_smoke_config.F90 create mode 100755 smoke/rrfs_smoke_data.F90 create mode 100644 smoke/rrfs_smoke_lsdep_wrapper.F90 create mode 100755 smoke/rrfs_smoke_lsdep_wrapper.meta create mode 100755 smoke/rrfs_smoke_postpbl.F90 create mode 100755 smoke/rrfs_smoke_postpbl.meta create mode 100755 smoke/rrfs_smoke_wrapper.F90 create mode 100755 smoke/rrfs_smoke_wrapper.meta create mode 100755 smoke/seas_data_mod.F90 create mode 100755 smoke/seas_mod.F90 create mode 100755 smoke/seas_ngac_mod.F90 diff --git a/smoke/dep_dry_gocart_mod.F90 b/smoke/dep_dry_gocart_mod.F90 new file mode 100755 index 000000000..6e15f2e57 --- /dev/null +++ b/smoke/dep_dry_gocart_mod.F90 @@ -0,0 +1,298 @@ +module dep_dry_gocart_mod + + use machine , only : kind_phys + use rrfs_smoke_data + + implicit none + + private + + public :: gocart_drydep_driver + +CONTAINS + +subroutine gocart_drydep_driver(numgas, & + moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & + ivgtyp,tsk,pbl,ust,znt,g, & + num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + num_moist,num_chem, & + its,ite, jts,jte, kts,kte,numgas + REAL(kind_phys), INTENT(IN ) :: g + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),& + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) ,& + INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) ,& + INTENT(IN ) :: dz8w, p8w,rho_phy + INTEGER, DIMENSION( ims:ime , jms:jme ) ,& + INTENT(IN ) :: ivgtyp + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) ,& + INTENT(INOUT) :: tsk, & + pbl, & + ust, & + xland,znt,hfx + +!! .. Local Scalars .. + + INTEGER :: iland, iprt, iseason, jce, jcs, & + n, nr, ipr, jpr, nvr, & + idrydep_onoff,imx,jmx,lmx + integer :: ii,jj,kk,i,j,k,nv + integer, dimension (1,1) :: ilwi + real(kind_phys), DIMENSION (5) :: tc,bems + real(kind_phys), dimension (1,1) :: z0,w10m,gwet,airden,airmas,& + delz_sfc,hflux,ts,pblz,ustar,& + ps,dvel,drydf + REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + + do nv=1,num_chem + do j=jts,jte + do i=its,ite + ddvel(i,j,nv)=0. + enddo + enddo + enddo + imx=1 + jmx=1 + lmx=1 + do j=jts,jte + do i=its,ite + dvel(1,1)=0. + ilwi(1,1)=0 + if(xland(i,j).gt.1.5)ilwi=1 +! for aerosols, ii=1 or ii=2 + ii=1 + if(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.23)ii=1 + airden(1,1)=rho_phy(i,kts,j) + delz_sfc(1,1)=dz8w(i,kts,j) + ustar(1,1)=ust(i,j) + hflux(1,1)=hfx(i,j) + pblz(1,1)=pbl(i,j) + ps(1,1)=p8w(i,kts,j)*.01 + z0(1,1)=znt(i,j) + ts(1,1)=tsk(i,j) + + call depvel_gocart(ii,imx,jmx,lmx,& + airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & + ps, z0, dvel, drydf,g) + do nv=1,num_chem + ddvel(i,j,nv)=dvel(1,1) + enddo + enddo + enddo +end subroutine gocart_drydep_driver + + + +SUBROUTINE depvel_gocart( & + ii,imx,jmx,lmx,& + airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & + ps, z0, dvel, drydf,g0) + +! **************************************************************************** +! * * +! * Calculate dry deposition velocity. * +! * * +! * Input variables: * +! * AEROSOL(k) - Logical, T = aerosol species, F = gas species * +! * IREG(i,j) - # of landtypes in grid square * +! * ILAND(i,j,ldt) - Land type ID for element ldt =1,IREG(i,j) * +! * IUSE(i,j,ldt) - Fraction of gridbox area occupied by land type * +! * element ldt * +! * USTAR(i,j) - Friction velocity (m s-1) * +! * DELZ_SFC(i,j) - Thickness of layer above surface * +! * PBLZ(i,j) - Mixing depth (m) * +! * Z0(i,j) - Roughness height (m) * +! * * +! * Determined in this subroutine (local): * +! * OBK - Monin-Obukhov length (m): set to 1.E5 m under * +! * neutral conditions * +! * Rs(ldt) - Bulk surface resistance(s m-1) for species k to * +! * surface ldt * +! * Ra - Aerodynamic resistance. * +! * Rb - Sublayer resistance. * +! * Rs - Surface resistance. * +! * Rttl - Total deposition resistance (s m-1) for species k * +! * Rttl(k) = Ra + Rb + Rs. * +! * * +! * Returned: * +! * DVEL(i,j,k) - Deposition velocity (m s-1) of species k * +! * DRYDf(i,j,k) - Deposition frequency (s-1) of species k, * +! * = DVEL / DELZ_SFC * +! * * +! **************************************************************************** + + + IMPLICIT NONE + INTEGER, INTENT(IN) :: imx,jmx,lmx + REAL(kind_phys), INTENT(IN) :: airden(imx,jmx), delz_sfc(imx,jmx) + REAL(kind_phys), INTENT(IN) :: hflux(imx,jmx), ts(imx,jmx) + REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx), pblz(imx,jmx) + REAL(kind_phys), INTENT(IN) :: ps(imx,jmx) + INTEGER, INTENT(IN) :: ilwi(imx,jmx) + REAL(kind_phys), INTENT(IN) :: z0(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: g0 + REAL(kind_phys), INTENT(OUT) :: dvel(imx,jmx), drydf(imx,jmx) + + REAL(kind_phys) :: obk, vds, czh, rttl, frac, logmfrac, psi_h, cz, eps + REAL(kind_phys) :: vd, ra, rb, rs + INTEGER :: i, j, k, ldt, iolson, ii + CHARACTER(LEN=50) :: msg + REAL(kind_phys) :: prss, tempk, tempc, xnu, ckustr, reyno, aird, diam, xm, z + REAL(kind_phys) :: frpath, speed, dg, dw, rt + REAL(kind_phys) :: rad0, rix, gfact, gfaci, rdc, rixx, rluxx, rgsx, rclx + REAL(kind_phys) :: dtmp1, dtmp2, dtmp3, dtmp4 + REAL(kind_phys) :: biofit,vk + + psi_h=0.0 + ! executable statements + j_loop: DO j = 1,jmx + i_loop: DO i = 1,imx + vk=.4 + vd = 0.0 + ra = 0.0 + rb = 0.0 ! only required for gases (SO2) + rs = 0.0 + +! **************************************************************************** +! * Compute the the Monin-Obhukov length. * +! * The direct computation of the Monin-Obhukov length is: * +! * * +! * - Air density * Cp * T(surface air) * Ustar^3 * +! * OBK = ---------------------------------------------- * +! * vK * g * Sensible Heat flux * +! * * +! * Cp = 1000 J/kg/K = specific heat at constant pressure * +! * vK = 0.4 = von Karman's constant * +! **************************************************************************** + + IF (hflux(i,j) == 0.0) THEN + obk = 1.0E5 + ELSE + ! MINVAL(hflux), MINVAL(airden), MINVAL(ustar) =?? + obk = -airden(i,j) * 1000.0 * ts(i,j) * (ustar(i,j))**3 & + / (vk * g0 * hflux(i,j)) +! -- debug: + IF ( obk == 0.0 ) WRITE(*,211) obk, i, j +211 FORMAT(1X,'OBK=', E11.2, 1X,' i,j = ', 2I4) + + END IF + + cz = delz_sfc(i,j) / 2.0 ! center of the grid box above surface + +! **************************************************************************** +! * (1) Aerosodynamic resistance Ra and sublayer resistance Rb. * +! * * +! * The Reynolds number REYNO diagnoses whether a surface is * +! * aerodynamically rough (REYNO > 10) or smooth. Surface is * +! * rough in all cases except over water with low wind speeds. * +! * * +! * For gas species over land and ice (REYNO >= 10) and for aerosol * +! * species for all surfaces: * +! * * +! * Ra = 1./VT (VT from GEOS Kzz at L=1, m/s). * +! * * +! * The following equations are from Walcek et al, 1986: * +! * * +! * For gas species when REYNO < 10 (smooth), Ra and Rb are combined * +! * as Ra: * +! * * +! * Ra = { ln(ku* z1/Dg) - Sh } / ku* eq.(13) * +! * * +! * where z1 is the altitude at the center of the lowest model layer * +! * (CZ); * +! * Sh is a stability correction function; * +! * k is the von Karman constant (0.4, vK); * +! * u* is the friction velocity (USTAR). * +! * * +! * Sh is computed as a function of z1 and L eq ( 4) and (5)): * +! * * +! * 0 < z1/L <= 1: Sh = -5 * z1/L * +! * z1/L < 0: Sh = exp{ 0.598 + 0.39*ln(E) - 0.09(ln(E))^2 } * +! * where E = min(1,-z1/L) (Balkanski, thesis). * +! * * +! * For gas species when REYNO >= 10, * +! * * +! * Rb = 2/ku* (Dair/Dg)**(2/3) eq.(12) * +! * where Dg is the gas diffusivity, and * +! * Dair is the air diffusivity. * +! * * +! * For aerosol species, Rb is combined with surface resistance as Rs. * +! * * +! **************************************************************************** + + frac = cz / obk + IF (frac > 1.0) frac = 1.0 + IF (frac > 0.0 .AND. frac <= 1.0) THEN + psi_h = -5.0*frac + ELSE IF (frac < 0.0) THEN + eps = MIN(1.0D0, -frac) + logmfrac = LOG(eps) + psi_h = EXP( 0.598 + 0.39 * logmfrac - 0.09 * (logmfrac)**2 ) + END IF + !-------------------------------------------------------------- + ! Aerosol species, Rs here is the combination of Rb and Rs. + + ra = (LOG(cz/z0(i,j)) - psi_h) / (vk*ustar(i,j)) + + vds = 0.002*ustar(i,j) + IF (obk < 0.0) & + vds = vds * (1.0+(-300.0/obk)**0.6667) + + czh = pblz(i,j)/obk + IF (czh < -30.0) vds = 0.0009*ustar(i,j)*(-czh)**0.6667 + + ! --Set Vds to be less than VDSMAX (entry in input file divided -- + ! by 1.E4). VDSMAX is taken from Table 2 of Walcek et al. [1986]. + ! Invert to get corresponding R + if(ii.eq.1)then + rs=1.0/MIN(vds,2.0D-2) + else + rs=1.0/MIN(vds,2.0D-3) + endif + + + ! ------ Set max and min values for bulk surface resistances ------ + + rs= MAX(1.0D0, MIN(rs, 9.9990D+3)) + +! **************************************************************************** +! * * +! * Compute dry deposition velocity. * +! * * +! * IUSE is the fraction of the grid square occupied by surface ldt in * +! * units of per mil (IUSE=500 -> 50% of the grid square). Add the * +! * contribution of surface type ldt to the deposition velocity; this is * +! * a loop over all surface types in the gridbox. * +! * * +! * Total resistance = Ra + Rb + Rs. +! * * +! **************************************************************************** + + rttl = ra + rb + rs + vd = vd + 1./rttl + + ! ------ Load array DVEL ------ + dvel(i,j) = vd * 1.2 + + ! -- Set a minimum value for DVEL + ! MIN(VdSO2) = 2.0e-3 m/s over ice + ! = 3.0e-3 m/s over land + ! MIN(vd_aerosol) = 1.0e-4 m/s + + IF (dvel(i,j) < 1.0E-4) dvel(i,j) = 1.0E-4 + drydf(i,j) = dvel(i,j) / delz_sfc(i,j) + + END DO i_loop + END DO j_loop + +END SUBROUTINE depvel_gocart + +end module dep_dry_gocart_mod diff --git a/smoke/dep_dry_mod.F90 b/smoke/dep_dry_mod.F90 new file mode 100755 index 000000000..140db6002 --- /dev/null +++ b/smoke/dep_dry_mod.F90 @@ -0,0 +1,300 @@ +module dep_dry_mod + + use machine , only : kind_phys + use rrfs_smoke_config, only : epsilc, GOCART_SIMPLE => CHEM_OPT_GOCART, CTRA_OPT_NONE +! use chem_tracers_mod, only : p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms, +! & +! config_flags => chem_config + use dep_dry_gocart_mod + use dep_simple_mod + use dep_vertmx_mod +! use aero_soa_vbs_mod, only : soa_vbs_depdriver + + implicit none + + + private + + public :: dry_dep_driver + +contains + + subroutine dry_dep_driver(data,ktau,dtstep,julday,current_month,t_phy,p_phy, & + moist,p8w,rmol,alt,gmt,t8w,raincv, & + chem,rho_phy,dz8w,exch_h,hfx, & + ivgtyp,tsk,gsw,vegfra,pbl,ust,znt,z,z_at_w, & + xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & + anh3,ddep,dep_vel_o3,g, & + e_co,kemit,snowh,numgas, & + num_chem,num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- +! USE module_model_constants +! USE module_configure +! USE module_state_description +! USE module_dep_simple +! USE module_initial_chem_namelists,only:p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms +! USE module_vertmx_wrf +! USE module_chemvars,only:epsilc +! USE module_data_sorgam +! USE module_aerosols_sorgam +! USE module_gocart_settling +! use module_dep_simple +! USE module_gocart_drydep,only: gocart_drydep_driver +! USE module_aerosols_soa_vbs, only: soa_vbs_depdriver +! USE module_mosaic_drydep, only: mosaic_drydep_driver +! USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate + IMPLICIT NONE + type(smoke_data), pointer, intent(inout) :: data + + INTEGER, INTENT(IN ) :: numgas, current_month, & + num_chem,num_moist, julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + INTEGER, INTENT(IN ) :: kemit + REAL(kind_phys), DIMENSION( ims:ime, kms:kemit, jms:jme ), & + INTENT(IN ) :: & + e_co + + + + + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t8w, & + dz8w, & + p8w,z_at_w , & + exch_h,rho_phy,z + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3 + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + snowh, & + raincv, & + ust, & + hfx, & + xland, & + xlat, & + xlong, & + znt,rmol + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: ddep + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(OUT) :: & + dep_vel_o3 + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + p_phy, & + t_phy + + REAL(kind_phys), INTENT(IN ) :: & + dtstep,g,gmt + +!--- deposition and emissions stuff +! .. Parameters .. +! .. +! .. Local Scalars .. + + REAL(kind_phys) :: cdt, factor + + INTEGER :: idrydep_onoff + +! INTEGER :: chem_conv_tr, chem_opt + +! CHARACTER (4) :: luse_typ,mminlu_loc +! .. +! .. Local Arrays .. + REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + +! REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy + REAL(kind_phys), DIMENSION( kts:kte ) :: dryrho_1d + +! turbulent transport + real(kind_phys) :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) + integer :: i,j,k,nv +! +! necessary for aerosols (module dependent) +! + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_def + REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_zcen + +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min + +! chem_opt = chem_opt +! chem_conv_tr = chem_conv_tr + +! +! compute dry deposition velocities = ddvel +! +! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine +! only when drydep_opt == WESELY +! the wesely_driver routine computes aer_res, and currently +! you cannot compute aerosol drydep without it !! +! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines +! +! write(6,*)'call dry dep driver' + dep_vel_o3(:,:)=0. + ddvel(:,:,:) = 0.0 + idrydep_onoff = 0 + +! drydep_select: SELECT CASE(drydep_opt) + +! CASE ( WESELY ) +! +! drydep_opt == WESELY means +! wesely for gases +! other (appropriate) routine for aerosols +! +! CALL wrf_debug(15,'DOING DRY DEP VELOCITIES WITH WESELY METHOD') + + IF( chem_opt /= GOCART_SIMPLE ) THEN + call wesely_driver(data,ktau,dtstep, & + current_month, & + gmt,julday,t_phy,moist,p8w,t8w,raincv, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & + ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& + snowh,numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ENDIF + IF (( chem_opt == GOCART_SIMPLE ) .or. & + ( chem_opt == GOCARTRACM_KPP) .or. & + ( chem_opt == 316) .or. & + ( chem_opt == 317) .or. & +! ( chem_opt == 502) .or. & + (chem_opt == 304 )) then +! +! this does aerosol species (dust,seas, bc,oc) for gocart only +! this does aerosol species (dust,seas, bc,oc,sulf) for gocart only +!, + call gocart_drydep_driver(numgas, & + moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & + ivgtyp,tsk,pbl,ust,znt,g, & + num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE if (chem_opt == 501 ) then +! for caesium .1cm/s +! + ddvel(:,:,:)=.001 + ELSE if (chem_opt == 108 ) then +!! call soa_vbs_depdriver (ust,t_phy, & +!! moist,p8w,rmol,znt,pbl, & +!! alt,p_phy,chem,rho_phy,dz8w, & +!! h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & +!! aer_res,ddvel(:,:,numgas+1:num_chem), & +!! num_chem-numgas, & +!! ids,ide, jds,jde, kds,kde, & +!! ims,ime, jms,jme, kms,kme, & +!! its,ite, jts,jte, kts,kte ) +! limit aerosol ddvels to <= 0.5 m/s +! drydep routines occasionally produce unrealistically-large particle +! diameter leading to unrealistically-large sedimentation velocity + ddvel(:,:,numgas+1:num_chem) = min( 0.50, ddvel(:,:,numgas+1:num_chem)) + ELSE + !Set dry deposition velocity to zero when using the + !chemistry tracer mode. + ddvel(:,:,:) = 0. + END IF + idrydep_onoff = 1 + +! +! Compute dry deposition according to NGAC +! + cdt = real(dtstep, kind=kind_phys) + do nv = 1, num_chem + do j = jts, jte + do i = its, ite + factor = 1._kind_phys - exp(-ddvel(i,j,nv)*cdt/dz8w(i,kts,j)) + ddep(i,j,nv) = max(0.0, factor * chem(i,kts,j,nv)) & !ug/m2/s + * (p8w(i,kts,j)-p8w(i,kts+1,j))/g/dtstep + end do + end do + end do + + +! This will be called later from subgrd_transport_driver.F !!!!!!!! +! +! + do 100 j=jts,jte + do 100 i=its,ite + if(p_dust_1.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_dust_1) + pblst=0. +! +! +!-- start with vertical mixing +! + do k=kts,kte+1 + zzfull(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) + enddo + + if (chem_conv_tr == CTRA_OPT_NONE) then + ekmfull = 0. + else + ekmfull(kts)=0. + do k=kts+1,kte + ekmfull(k)=max(1.e-6,exch_h(i,k,j)) + enddo + ekmfull(kte+1)=0. + end if + +!!$! UNCOMMENT THIS AND FINE TUNE LEVELS TO YOUR DOMAIN IF YOU WANT TO +!!$! FORCE MIXING TO A CERTAIN DEPTH: +!!$! +!!$! --- Mix the emissions up several layers +! + do k=kts,kte + zz(k)=z(i,k,j)-z_at_w(i,kts,j) + enddo +! vertical mixing routine (including deposition) +! need to be careful here with that dumm tracer in spot 1 +! do not need lho,lho2 +! (03-may-2006 rce - calc dryrho_1d and pass it to vertmx) +! +! if(p_o3.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_o3) + do nv=1,num_chem-0 + do k=kts,kte + pblst(k)=max(epsilc,chem(i,k,j,nv)) + dryrho_1d(k) = 1./alt(i,k,j) + enddo + + !mix_select: SELECT CASE(chem_opt) + !CASE DEFAULT + call vertmx(data,dtstep,pblst,ekmfull,dryrho_1d, & + zzfull,zz,ddvel(i,j,nv),kts,kte) + + !END SELECT mix_select + + do k=kts,kte + chem(i,k,j,nv)=max(epsilc,pblst(k)) + enddo + enddo +100 continue + +END SUBROUTINE dry_dep_driver + +end module dep_dry_mod diff --git a/smoke/dep_simple_mod.F90 b/smoke/dep_simple_mod.F90 new file mode 100755 index 000000000..9751b19a6 --- /dev/null +++ b/smoke/dep_simple_mod.F90 @@ -0,0 +1,763 @@ +module dep_simple_mod + + use rrfs_smoke_data + use rrfs_smoke_config, GOCART_SIMPLE => CHEM_OPT_GOCART, chem_opt=>chem_opt +! use chem_tracers_mod, config_flags => chem_config + +! USE module_data_sorgam + + implicit none + +!-------------------------------------------------- +! .. Default Accessibility .. +!-------------------------------------------------- + PUBLIC + + + CONTAINS + +SUBROUTINE wesely_driver( data, ktau, dtstep, current_month, & + gmt, julday, t_phy,moist, p8w, t8w, raincv, & + p_phy, chem, rho_phy, dz8w, ddvel, aer_res_def, & + aer_res_zcen, ivgtyp, tsk, gsw, vegfra, pbl, & + rmol, ust, znt, xlat, xlong, & + z, z_at_w, snowh, numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + implicit none +!-------------------------------------------------- +! Wesely dry dposition driver +!-------------------------------------------------- + +! USE module_model_constants +! USE module_wrf_control,only:num_moist,num_chem +! USE module_state_description +! USE module_initial_chem_namelists +! USE module_data_sorgam +! USE module_state_description, only: param_first_scalar + type(smoke_data), intent(inout), pointer :: data + INTEGER, INTENT(IN ) :: julday, & + numgas, current_month, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: ktau + REAL(kind_phys), INTENT(IN ) :: dtstep,gmt + +!-------------------------------------------------- +! advected moisture variables +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN ) :: & + moist +!-------------------------------------------------- +! advected chemical species +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT ) :: & + chem +!-------------------------------------------------- +! deposition velocities +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( its:ite, jts:jte, num_chem ), INTENT(INOUT ) :: & + ddvel +!-------------------------------------------------- +! input from met model +!-------------------------------------------------- + REAL(KIND_PHYS), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + z, & + t8w, & + p8w, & + z_at_w, & + rho_phy + INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: & + ivgtyp + REAL(KIND_PHYS), DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + rmol, & + ust, & + xlat, & + xlong, & + raincv, & + znt + REAL(KIND_PHYS), intent(inout) :: aer_res_def(its:ite,jts:jte) + REAL(KIND_PHYS), intent(inout) :: aer_res_zcen(its:ite,jts:jte) + REAL(KIND_PHYS), INTENT(IN) :: snowh(ims:ime,jms:jme) + +!-------------------------------------------------- +! .. Local Scalars +!-------------------------------------------------- + REAL(kind_phys) :: clwchem, dvfog, dvpart, pa, rad, dep_vap + REAL(KIND_PHYS) :: rhchem, ta, ustar, vegfrac, z1, zntt + INTEGER :: i, iland, iprt, iseason, j, jce, jcs, n, nr, ipr,jpr,nvr + LOGICAL :: highnh3, rainflag, vegflag, wetflag +!-------------------------------------------------- +! .. Local Arrays +!-------------------------------------------------- + REAL(KIND_PHYS) :: p(kts:kte) + REAL(KIND_PHYS) :: srfres(numgas) + REAL(KIND_PHYS) :: ddvel0d(numgas) + +!----------------------------------------------------------- +! necessary for aerosols (module dependent) +!----------------------------------------------------------- + real(kind_phys) :: rcx(numgas) + + +!----------------------------------------------------------- +! .. Intrinsic Functions +!----------------------------------------------------------- +! integer :: chem_opt + + INTRINSIC max, min + + data => get_thread_smoke_data() + +! chem_opt = chem_opt + + dep_vap = depo_fact + !print*,'hli simple chem_opt',chem_opt + +! CALL wrf_debug(15,'in dry_dep_wesely') + + if( julday < 90 .or. julday > 270 ) then + iseason = 2 +! CALL wrf_debug(15,'setting iseason to 2') + else + iseason = 1 + endif + + +tile_lat_loop : & + do j = jts,jte +tile_lon_loop : & + do i = its,ite + iprt = 0 + + iland = luse2usgs( ivgtyp(i,j) ) +!-- + + ta = tsk(i,j) + rad = gsw(i,j) + vegfrac = vegfra(i,j) + pa = .01*p_phy(i,kts,j) + clwchem = moist(i,kts,j,p_qc) + ustar = ust(i,j) + zntt = znt(i,j) + z1 = z_at_w(i,kts+1,j) - z_at_w(i,kts,j) +!----------------------------------------------------------- +! Set logical default values +!----------------------------------------------------------- + rainflag = .FALSE. + wetflag = .FALSE. + highnh3 = .FALSE. +! if(p_qr > 1) then +! if(moist(i,kts,j,p_qr) > 1.e-18 .or. raincv(i,j) > 0.) then +! rainflag = .true. +! endif +! endif + rhchem = MIN( 100.,100. * moist(i,kts,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,kts,j)-273.)/(t_phy(i,kts,j)-36.))/pa)) + rhchem = MAX(5.,RHCHEM) + if (rhchem >= 95.) wetflag = .true. + +!----------------------------------------------------------- +!--- deposition +!----------------------------------------------------------- +! if(snowc(i,j).gt.0.)iseason=4 + CALL rc( data, rcx, ta, rad, rhchem, iland, & + iseason, numgas, wetflag, rainflag, highnh3, & + iprt, moist(i,kts,j,p_qv), p8w(i,kts,j) ) + srfres(1:numgas-2) = rcx(1:numgas-2) + srfres(numgas-1:numgas) = 0. + CALL deppart( data, rmol(i,j), ustar, rhchem, clwchem, iland, dvpart, dvfog ) + ddvel0d(1:numgas) = 0. + aer_res_def(i,j) = 0. + aer_res_zcen(i,j) = 0. + CALL landusevg( data, ddvel0d, ustar, rmol(i,j), zntt, z1, dvpart, iland, & + numgas, srfres, aer_res_def(i,j), aer_res_zcen(i,j), p_sulf ) + +!----------------------------------------------------------- +!wig: CBMZ does not have HO and HO2 last so need to copy all species +! ddvel(i,j,1:numgas-2)=ddvel0d(1:numgas-2) +!----------------------------------------------------------- + ddvel(i,j,1:numgas) = ddvel0d(1:numgas) + end do tile_lon_loop + end do tile_lat_loop + +!----------------------------------------------------------- +! For the additional CBMZ species, assign similar RADM counter parts for +! now. Short lived species get a zero velocity since dry dep should be +! unimportant. **ALSO**, treat p_sulf as h2so4 vapor, not aerosol sulfate +!----------------------------------------------------------- +! + +!----------------------------------------------------------- +! For gocartsimple : need msa. On the other hand sulf comes from aerosol routine +!----------------------------------------------------------- + if (chem_opt == GOCART_SIMPLE ) then + do j=jts,jte + do i=its,ite + ddvel(i,j,p_msa) = ddvel(i,j,p_sulf) + ddvel(i,j,p_sulf) = 0. + ddvel(i,j,p_dms) = 0. + end do + end do + end if + +END SUBROUTINE wesely_driver + + SUBROUTINE rc( data, rcx, t, rad, rh, iland, & + iseason, numgas, wetflag, rainflag, highnh3, & + iprt, spec_hum, p_srf ) +!---------------------------------------------------------------------- +! THIS SUBROUTINE CALCULATES SURFACE RESISTENCES ACCORDING +! TO THE MODEL OF +! M. L. WESELY, +! ATMOSPHERIC ENVIRONMENT 23 (1989), 1293-1304 +! WITH SOME ADDITIONS ACCORDING TO +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODYFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +!---------------------------------------------------------------------- + +! USE module_state_description +! USE module_initial_chem_namelists + implicit none + type(smoke_data), pointer, intent(inout) :: data +!---------------------------------------------------------------------- +! ... dummy arguments +!---------------------------------------------------------------------- + INTEGER, intent(in) :: iland, iseason, numgas + INTEGER, intent(in) :: iprt + REAL(KIND_PHYS), intent(in) :: rad, rh + REAL(KIND_PHYS), intent(in) :: t ! surface temp (K) + REAL(KIND_PHYS), intent(in) :: p_srf ! surface pressure (Pa) + REAL(KIND_PHYS), intent(in) :: spec_hum ! surface specific humidity (kg/kg) + real(kind_phys), intent(out) :: rcx(numgas) + LOGICAL, intent(in) :: highnh3, rainflag, wetflag + +!---------------------------------------------------------------------- +! .. Local Scalars .. +!---------------------------------------------------------------------- + REAL(KIND_PHYS), parameter :: t0 = 298. + REAL(KIND_PHYS), parameter :: tmelt = 273.16 + INTEGER :: lt, n + INTEGER :: chem_opt + REAL(KIND_PHYS) :: rclx, rdc, resice, rgsx, rluo1, rluo2 + REAL(KIND_PHYS) :: rlux, rmx, rs, rsmx, rdtheta, z, wrk + REAL(KIND_PHYS) :: qs, es, ws, dewm, dv_pan, drat + REAL(KIND_PHYS) :: crs, tc + REAL(KIND_PHYS) :: rs_pan, tc_pan + LOGICAL :: has_dew +!---------------------------------------------------------------------- +! .. Local Arrays .. +!---------------------------------------------------------------------- + REAL(KIND_PHYS) :: hstary(numgas) + +!---------------------------------------------------------------------- +! .. Intrinsic Functions .. +!---------------------------------------------------------------------- + INTRINSIC exp + + chem_opt = chem_opt + + rcx(1:numgas) = 1. + + tc = t - 273.15 + rdtheta = 0. + + z = 200./(rad+0.1) + +!!! HARDWIRE VALUES FOR TESTING +! z=0.4727409 +! tc=22.76083 +! t=tc+273.15 +! rad = 412.8426 +! rainflag=.false. +! wetflag=.false. + + IF ( tc<=0. .OR. tc>=40. ) THEN + rs = 9999. + ELSE + rs = data%ri(iland,iseason)*(1+z*z)*(400./(tc*(40.-tc))) + END IF + rdc = 100.*(1. + 1000./(rad + 10.))/(1. + 1000.*rdtheta) + rluo1 = 1./(1./3000. + 3./data%rlu(iland,iseason)) + rluo2 = 1./(1./1000. + 3./data%rlu(iland,iseason)) + resice = 1000.*exp( -(tc + 4.) ) + wrk = (t0 - t)/(t0*t) + + + DO n = 1, numgas + IF( data%hstar(n) /= 0. ) then + hstary(n) = data%hstar(n)*exp( data%dhr(n)*wrk ) +!---------------------------------------------------------------------- +! SPECIAL TREATMENT FOR HNO3, HNO4, H2O2, PAA +!---------------------------------------------------------------------- + rmx = 1./(hstary(n)/3000. + 100.*data%f0(n)) + rsmx = rs*data%dratio(n) + rmx + rclx = 1./(1.e-5*hstary(n)/data%rcls(iland,iseason) & + + data%f0(n)/data%rclo(iland,iseason)) + resice + rgsx = 1./(1.e-5*hstary(n)/data%rgss(iland,iseason) & + + data%f0(n)/data%rgso(iland,iseason)) + resice + rlux = data%rlu(iland,iseason)/(1.e-5*hstary(n) + data%f0(n)) + resice + IF( wetflag ) THEN + rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo1) + END IF + IF( rainflag ) THEN + rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo2) + END IF + rcx(n) = 1./(1./rsmx + 1./rlux + 1./(rdc + rclx) + 1./(data%rac(iland,iseason) + rgsx)) + rcx(n) = max( 1.,rcx(n) ) + end IF + END DO + +!-------------------------------------------------- +! SPECIAL TREATMENT FOR OZONE +!-------------------------------------------------- +! SPECIAL TREATMENT FOR SO2 (Wesely) +! HSTARY(P_SO2)=DATA%HSTAR(P_SO2)*EXP(DATA%DHR(P_SO2)*(1./T-1./298.)) +! RMX=1./(HSTARY(P_SO2)/3000.+100.*DATA%F0(P_SO2)) +! RSMX=RS*DATA%DRATIO(P_SO2)+RMX +! RLUX=DATA%RLU(ILAND,ISEASON)/(1.E-5*HSTARY(P_SO2)+DATA%F0(P_SO2)) +! & +RESICE +! RCLX=DATA%RCLS(ILAND,ISEASON)+RESICE +! RGSX=DATA%RGSS(ILAND,ISEASON)+RESICE +! IF ((wetflag).OR.(RAINFLAG)) THEN +! IF (ILAND.EQ.1) THEN +! RLUX=50. +! ELSE +! RLUX=100. +! END IF +! END IF +! RCX(P_SO2)=1./(1./RSMX+1./RLUX+1./(RDC+RCLX) +! & +1./(DATA%RAC(ILAND,ISEASON)+RGSX)) +! IF (RCX(P_SO2).LT.1.) RCX(P_SO2)=1. + +!-------------------------------------------------- +! SO2 according to Erisman et al. 1994 +! R_STOM +!-------------------------------------------------- +is_so2 : & + if( p_so2 > 1 ) then + rsmx = rs*data%dratio(p_so2) +!-------------------------------------------------- +! R_EXT +!-------------------------------------------------- + IF (tc> -1. ) THEN + IF (rh<81.3) THEN + rlux = 25000.*exp(-0.0693*rh) + ELSE + rlux = 0.58E12*exp(-0.278*rh) + END IF + END IF + IF (((wetflag) .OR. (rainflag)) .AND. (tc> -1. )) THEN + rlux = 1. + END IF + IF ((tc>= -5. ) .AND. (tc<= -1. )) THEN + rlux = 200. + END IF + IF (tc< -5. ) THEN + rlux = 500. + END IF +!-------------------------------------------------- +! INSTEAD OF R_INC R_CL and R_DC of Wesely are used +!-------------------------------------------------- + rclx = data%rcls(iland,iseason) +!-------------------------------------------------- +! DRY SURFACE +!-------------------------------------------------- + rgsx = 1000. +!-------------------------------------------------- +! WET SURFACE +!-------------------------------------------------- + IF ((wetflag) .OR. (rainflag)) THEN + IF (highnh3) THEN + rgsx = 0. + ELSE + rgsx = 500. + END IF + END IF +!-------------------------------------------------- +! WATER +!-------------------------------------------------- + IF (iland==iswater_temp) THEN + rgsx = 0. + END IF +!-------------------------------------------------- +! SNOW +!-------------------------------------------------- + IF( iseason==4 .OR. iland==isice_temp ) THEN + IF( tc > 2. ) THEN + rgsx = 0. + else IF ( tc >= -1. .AND. tc <= 2. ) THEN + rgsx = 70.*(2. - tc) + else IF ( tc < -1. ) THEN + rgsx = 500. + END IF + END IF +!-------------------------------------------------- +! TOTAL SURFACE RESISTENCE +!-------------------------------------------------- + IF ((iseason/=4) .AND. (data%ixxxlu(iland)/=1) .AND. (iland/=iswater_temp) .AND. & + (iland/=isice_temp)) THEN + rcx(p_so2) = 1./(1./rsmx+1./rlux+1./(rclx+rdc+rgsx)) + ELSE + rcx(p_so2) = rgsx + END IF + rcx(p_so2) = max( 1.,rcx(p_so2) ) + end if is_so2 +!-------------------------------------------------- +! NH3 according to Erisman et al. 1994 +! R_STOM +!-------------------------------------------------- + END SUBROUTINE rc + + SUBROUTINE deppart( data, rmol, ustar, rh, clw, iland, & + dvpart, dvfog ) +!-------------------------------------------------- +! THIS SUBROUTINE CALCULATES SURFACE DEPOSITION VELOCITIES +! FOR FINE AEROSOL PARTICLES ACCORDING TO THE MODEL OF +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODIFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +!-------------------------------------------------- + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: iland + REAL(KIND_PHYS), intent(in) :: clw, rh, rmol, ustar + REAL(KIND_PHYS), intent(out) :: dvfog, dvpart + +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC exp + + dvpart = ustar/data%kpart(iland) + IF (rmol<0.) THEN +!-------------------------------------------------- +! UNSTABLE LAYERING CORRECTION +!-------------------------------------------------- + dvpart = dvpart*(1.+(-300.*rmol)**0.66667) + END IF + IF (rh>80.) THEN +!-------------------------------------------------- +! HIGH RELATIVE HUMIDITY CORRECTION +! ACCORDING TO J. W. ERISMAN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 321-332 +!-------------------------------------------------- + dvpart = dvpart*(1.+0.37*exp((rh-80.)/20.)) + END IF + +!-------------------------------------------------- +! SEDIMENTATION VELOCITY OF FOG WATER ACCORDING TO +! R. FORKEL, W. SEIDL, R. DLUGI AND E. DEIGELE +! J. GEOPHYS. RES. 95D (1990), 18501-18515 +!-------------------------------------------------- + dvfog = 0.06*clw + IF (data%ixxxlu(iland)==5) THEN +!-------------------------------------------------- +! TURBULENT DEPOSITION OF FOG WATER IN CONIFEROUS FOREST ACCORDI +! A. T. VERMEULEN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 375-386 +!-------------------------------------------------- + dvfog = dvfog + 0.195*ustar*ustar + END IF + + END SUBROUTINE deppart + + SUBROUTINE landusevg( data, vgs, ustar, rmol, z0, zz, & + dvparx, iland, numgas, srfres, aer_res_def, & + aer_res_zcen, p_sulf ) +!-------------------------------------------------- +! This subroutine calculates the species specific deposition velocit +! as a function of the local meteorology and land use. The depositi +! Velocity is also landuse specific. +! Reference: Hsieh, C.M., Wesely, M.L. and Walcek, C.J. (1986) +! A Dry Deposition Module for Regional Acid Deposition +! EPA report under agreement DW89930060-01 +! Revised version by Darrell Winner (January 1991) +! Environmental Engineering Science 138-78 +! California Institute of Technology +! Pasadena, CA 91125 +! Modified by Winfried Seidl (August 1997) +! Fraunhofer-Institut fuer Atmosphaerische Umweltforschung +! Garmisch-Partenkirchen, D-82467 +! for use of Wesely and Erisman surface resistances +! Inputs: +! Ustar : The grid average friction velocity (m/s) +! Rmol : Reciprocal of the Monin-Obukhov length (1/m) +! Z0 : Surface roughness height for the grid square (m) +! SrfRes : Array of landuse/atmospheric/species resistances (s/m) +! Slist : Array of chemical species codes +! Dvparx : Array of surface deposition velocity of fine aerosol p +! Outputs: +! Vgs : Array of species and landuse specific deposition +! velocities (m/s) +! Vg : Cell-average deposition velocity by species (m/s) +! Variables used: +! SCPR23 : (Schmidt #/Prandtl #)**(2/3) Diffusion correction fac +! Zr : Reference Height (m) +! Iatmo : Parameter specifying the stabilty class (Function of +! Z0 : Surface roughness height (m) +! karman : Von Karman constant (from module_model_constants) +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: iland, numgas, p_sulf + REAL(KIND_PHYS), intent(in) :: dvparx, ustar, z0, zz + REAL(KIND_PHYS), intent(inout) :: rmol + REAL(KIND_PHYS), intent(inout) :: aer_res_def + REAL(KIND_PHYS), intent(inout) :: aer_res_zcen +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(in) :: srfres(numgas) + REAL(KIND_PHYS), intent(out) :: vgs(numgas) + +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: jspec + REAL(KIND_PHYS) :: vgp, vgpart, zr + REAL(KIND_PHYS) :: rmol_tmp +!-------------------------------------------------- +! .. Local Arrays .. +!-------------------------------------------------- + REAL(KIND_PHYS) :: vgspec(numgas) + +!-------------------------------------------------- +! Calculate aerodynamic resistance for reference +! height = layer center +!-------------------------------------------------- + zr = zz*.5 + rmol_tmp = rmol + CALL depvel( data, numgas, rmol_tmp, zr, z0, ustar, & + vgspec, vgpart, aer_res_zcen ) +!-------------------------------------------------- +! Set the reference height (2.0 m) +!-------------------------------------------------- +! zr = 10.0 + zr = 2.0 + +!-------------------------------------------------- +! CALCULATE THE DEPOSITION VELOCITY without any surface +! resistance term, i.e. 1 / (ra + rb) +!-------------------------------------------------- + CALL depvel( data, numgas, rmol, zr, z0, ustar, & + vgspec, vgpart, aer_res_def ) + +!-------------------------------------------------- +! Calculate the deposition velocity for each species +! and grid cell by looping through all the possibile combinations +! of the two +!-------------------------------------------------- + vgp = 1.0/((1.0/vgpart)+(1.0/dvparx)) +!-------------------------------------------------- +! Loop through the various species +!-------------------------------------------------- + DO jspec = 1, numgas +!-------------------------------------------------- +! Add in the surface resistance term, rc (SrfRes) +!-------------------------------------------------- + vgs(jspec) = 1.0/(1.0/vgspec(jspec) + srfres(jspec)) + END DO + vgs(p_sulf) = vgp + + CALL cellvg( data, vgs, ustar, zz, zr, rmol, numgas ) + + END SUBROUTINE landusevg + + SUBROUTINE cellvg( data, vgtemp, ustar, dz, zr, rmol, nspec ) +!-------------------------------------------------- +! THIS PROGRAM HAS BEEN DESIGNED TO CALCULATE THE CELL AVERAGE +! DEPOSITION VELOCITY GIVEN THE VALUE OF VG AT SOME REFERENCE +! HEIGHT ZR WHICH IS MUCH SMALLER THAN THE CELL HEIGHT DZ. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (February 1991) +!.....PROGRAM VARIABLES... +! VgTemp - DEPOSITION VELOCITY AT THE REFERENCE HEIGHT +! USTAR - FRICTION VELOCITY +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! DZ - CELL HEIGHT +! CELLVG - CELL AVERAGE DEPOSITION VELOCITY +! VK - VON KARMAN CONSTANT +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: nspec + REAL(KIND_PHYS), intent(in) :: dz, rmol, ustar, zr +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(out) :: vgtemp(nspec) +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: nss + REAL(KIND_PHYS) :: a, fac, pdz, pzr, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog, sqrt + +!-------------------------------------------------- +! Set the von Karman constant +!-------------------------------------------------- + vk = karman + +!-------------------------------------------------- +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE +!-------------------------------------------------- + DO nss = 1, nspec + IF (rmol < 0.) THEN + pdz = sqrt(1.0 - 9.0*dz*rmol) + pzr = sqrt(1.0 - 9.0*zr*rmol) + fac = ((pdz - 1.0)/(pzr - 1.0))*((pzr + 1.0)/(pdz + 1.0)) + a = 0.74*dz*alog(fac) + (0.164/rmol)*(pdz-pzr) + ELSE IF (rmol == 0.) THEN + a = 0.74*(dz*alog(dz/zr) - dz + zr) + ELSE + a = 0.74*(dz*alog(dz/zr) - dz + zr) + (2.35*rmol)*(dz - zr)**2 + END IF +!-------------------------------------------------- +! CALCULATE THE DEPOSITION VELOCITIY +!-------------------------------------------------- + vgtemp(nss) = vgtemp(nss)/(1.0 + vgtemp(nss)*a/(vk*ustar*(dz - zr))) + END DO + + END SUBROUTINE cellvg + + SUBROUTINE depvel( data, numgas, rmol, zr, z0, ustar, & + depv, vgpart, aer_res ) +!-------------------------------------------------- +! THIS FUNCTION HAS BEEN DESIGNED TO EVALUATE AN UPPER LIMIT +! FOR THE POLLUTANT DEPOSITION VELOCITY AS A FUNCTION OF THE +! SURFACE ROUGHNESS AND METEOROLOGICAL CONDITIONS. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (Feb. 1991) +! by Winfried Seidl (Aug. 1997) +!.....PROGRAM VARIABLES... +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! Z0 - SURFACE ROUGHNESS HEIGHT +! SCPR23 - (Schmidt #/Prandtl #)**(2/3) Diffusion correction fact +! UBAR - ABSOLUTE VALUE OF SURFACE WIND SPEED +! DEPVEL - POLLUTANT DEPOSITION VELOCITY +! Vk - VON KARMAN CONSTANT +! USTAR - FRICTION VELOCITY U* +! POLINT - POLLUTANT INTEGRAL +! AER_RES - AERODYNAMIC RESISTANCE +!.....REFERENCES... +! MCRAE, G.J. ET AL. (1983) MATHEMATICAL MODELING OF PHOTOCHEMICAL +! AIR POLLUTION, ENVIRONMENTAL QUALITY LABORATORY REPORT 18, +! CALIFORNIA INSTITUTE OF TECHNOLOGY, PASADENA, CALIFORNIA. +!.....RESTRICTIONS... +! 1. THE MODEL EDDY DIFFUSIVITIES ARE BASED ON MONIN-OBUKHOV +! SIMILARITY THEORY AND SO ARE ONLY APPLICABLE IN THE +! SURFACE LAYER, A HEIGHT OF O(30M). +! 2. ALL INPUT UNITS MUST BE CONSISTENT +! 3. THE PHI FUNCTIONS USED TO CALCULATE THE FRICTION +! VELOCITY U* AND THE POLLUTANT INTEGRALS ARE BASED +! ON THE WORK OF BUSINGER ET AL.(1971). +! 4. THE MOMENTUM AND POLLUTANT DIFFUSIVITIES ARE NOT +! THE SAME FOR THE CASES L<0 AND L>0. +!-------------------------------------------------- + +! USE module_model_constants, only: karman + implicit none + type(smoke_data), pointer, intent(inout) :: data + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + INTEGER, intent(in) :: numgas + REAL(KIND_PHYS), intent(in) :: ustar, z0, zr + REAL(KIND_PHYS), intent(out) :: vgpart, aer_res + REAL(KIND_PHYS), intent(inout) :: rmol +!-------------------------------------------------- +! .. Array Arguments .. +!-------------------------------------------------- + REAL(KIND_PHYS), intent(out) :: depv(numgas) +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: l + REAL(KIND_PHYS) :: ao, ar, polint, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog +!-------------------------------------------------- +! Set the von Karman constant +!-------------------------------------------------- + vk = karman + +!-------------------------------------------------- +! Calculate the diffusion correction factor +! SCPR23 is calculated as (Sc/Pr)**(2/3) using Sc= 1.15 and Pr= 1.0 +! DATA%SCPR23 = 1.10 +!-------------------------------------------------- +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE +!-------------------------------------------------- + + if(abs(rmol) < 1.E-6 ) rmol = 0. + + IF (rmol<0) THEN + ar = ((1.0-9.0*zr*rmol)**(0.25)+0.001)**2 + ao = ((1.0-9.0*z0*rmol)**(0.25)+0.001)**2 + polint = 0.74*(alog((ar-1.0)/(ar+1.0))-alog((ao-1.0)/(ao+1.0))) + ELSE IF (rmol==0.) THEN + polint = 0.74*alog(zr/z0) + ELSE + polint = 0.74*alog(zr/z0) + 4.7*rmol*(zr-z0) + END IF + +!-------------------------------------------------- +! CALCULATE THE Maximum DEPOSITION VELOCITY +!-------------------------------------------------- + DO l = 1, numgas + depv(l) = ustar*vk/(2.0*data%scpr23(l)+polint) + END DO + vgpart = ustar*vk/polint + aer_res = polint/(karman*max(ustar,1.0e-4)) + + END SUBROUTINE depvel + + ! NOTE: dep_init is now in rrfs_smoke_data + +end module dep_simple_mod diff --git a/smoke/dep_vertmx_mod.F90 b/smoke/dep_vertmx_mod.F90 new file mode 100755 index 000000000..5933af271 --- /dev/null +++ b/smoke/dep_vertmx_mod.F90 @@ -0,0 +1,209 @@ +MODULE dep_vertmx_mod + use rrfs_smoke_data + use machine , only : kind_phys + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE vertmx( data, dt, phi, kt_turb, dryrho, & + zsigma, zsigma_half, vd, kts, ktem1 ) +! !! purpose - calculate change in time of phi due to vertical mixing +! !! and dry deposition (for 1 species, 1 vertical column, 1 time step) +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! +! !! modifications by R Easter, May 2006 +! !! added dryrho so this routine conserves column mass burde +! !! when dry deposition velocity is zero +! !! changed "kte" to "ktem1" for consistency with the kte in WRF +! +! ARGUMENTS +! +! dt = time step (s) +! phi = initial/final (at input/output) species mixing ratios at "T" points +! kt_turb = turbulent exchange coefficients (m^2/s) at "W" points +! dryrho = dry air density (kg/m^3) at "T" points +! zsigma = heights (m) at "W" points +! zsigma_half = heights (m) at "T" points +! vd = dry deposition velocity (m/s) +! kts, ktem1 = vertical indices of bottom and top "T" points +! + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 + REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: kt_turb, zsigma + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: dryrho, zsigma_half + REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: phi +! .. +! .. Local Scalars .. + INTEGER :: k +! .. +! .. Local Arrays .. + REAL(KIND=KIND_PHYS), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: b_coeff, lhs1, lhs2, lhs3, rhs +! .. +! .. External Subroutines .. +! EXTERNAL coeffs, rlhside, tridiag +! .. + CALL coeffs( data, kts, ktem1, dryrho, zsigma, zsigma_half, a_coeff, b_coeff ) + + CALL rlhside( data, kts, ktem1, kt_turb, dryrho, a_coeff, b_coeff, & + phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) + + CALL tridiag( data, kts, ktem1, lhs1, lhs2, lhs3, rhs ) + + DO k = kts,ktem1 + phi(k) = rhs(k) + END DO + + END SUBROUTINE vertmx + + +!----------------------------------------------------------------------- + SUBROUTINE rlhside( data, kts, ktem1, k_turb, dryrho, a_coeff, b_coeff, & + phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) + !! to calculate right and left hand sides in diffusion equation + !! for the tridiagonal solver + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 + REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: k_turb + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: b_coeff, dryrho + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: phi + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: lhs1, lhs2, lhs3, rhs +! .. +! .. Local Scalars .. + !REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .25, beta_implicit = .75 + REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .0, beta_implicit = 1. + INTEGER :: i + +! .. + i = kts + a2 = a_coeff(i+1)*k_turb(i+1) + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(vd*dryrho(i)+a2))*phi(i) + & + alfa_explicit*(a2*phi(i+1)) + lhs1(i) = 0. + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(vd*dryrho(i)+a2) + lhs3(i) = -beta_implicit*a2 + + DO i = kts+1, ktem1-1 + a1 = a_coeff(i)*k_turb(i) + a2 = a_coeff(i+1)*k_turb(i+1) + + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1+a2))*phi(i) + & + alfa_explicit*(a1*phi(i-1) + a2*phi(i+1)) + + lhs1(i) = -beta_implicit*a1 + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1+a2) + lhs3(i) = -beta_implicit*a2 + END DO + + i = ktem1 + a1 = a_coeff(i)*k_turb(i) + rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1 ))*phi(i) + & + alfa_explicit*(a1*phi(i-1)) + lhs1(i) = -beta_implicit*a1 + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1 ) + lhs3(i) = 0. + + END SUBROUTINE rlhside + + +!----------------------------------------------------------------------- + SUBROUTINE tridiag( data, kts, ktem1, a, b, c, f ) + !! to solve system of linear eqs on tridiagonal matrix n times n + !! after Peaceman and Rachford, 1955 + !! a,b,c,F - are vectors of order n + !! a,b,c - are coefficients on the LHS + !! F - is initially RHS on the output becomes a solution vector + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! .. Scalar Arguments .. + INTEGER, INTENT(IN) :: kts,ktem1 +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: a, b, c + REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: f +! .. +! .. Local Scalars .. + REAL(KIND_PHYS) :: p + INTEGER :: i +! .. +! .. Local Arrays .. + REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: q +! .. + q(kts) = -c(kts)/b(kts) + f(kts) = f(kts)/b(kts) + + DO i = kts+1, ktem1 + p = 1./(b(i)+a(i)*q(i-1)) + q(i) = -c(i)*p + f(i) = (f(i)-a(i)*f(i-1))*p + END DO + + DO i = ktem1 - 1, kts, -1 + f(i) = f(i) + q(i)*f(i+1) + END DO + + END SUBROUTINE tridiag + + +!----------------------------------------------------------------------- + SUBROUTINE coeffs( data, kts, ktem1, dryrho, & + z_sigma, z_sigma_half, a_coeff, b_coeff ) +! !! to calculate coefficients in diffusion equation +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! .. Scalar Arguments .. + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN) :: kts,ktem1 +! .. +! .. Array Arguments .. + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: z_sigma + REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: z_sigma_half, dryrho + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts+1:ktem1) :: a_coeff + REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: b_coeff +! .. +! .. Local Scalars .. + INTEGER :: i + REAL(KIND=KIND_PHYS) :: dryrho_at_w +! .. + DO i = kts, ktem1 + b_coeff(i) = 1./(dryrho(i)*(z_sigma(i+1)-z_sigma(i))) + END DO + + DO i = kts+1, ktem1 + dryrho_at_w = 0.5*(dryrho(i)+dryrho(i-1)) + a_coeff(i) = dryrho_at_w/(z_sigma_half(i)-z_sigma_half(i-1)) + END DO + + END SUBROUTINE coeffs + +!----------------------------------------------------------------------- +END MODULE dep_vertmx_mod diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 new file mode 100755 index 000000000..bfbe275f2 --- /dev/null +++ b/smoke/dep_wet_ls_mod.F90 @@ -0,0 +1,565 @@ +module dep_wet_ls_mod + use rrfs_smoke_data + use machine , only : kind_phys + use rrfs_smoke_config + use physcons, only : grav => con_g +! use chem_tracers_mod +! use chem_rc_mod +! use chem_tracers_mod +! use chem_const_mod, only : grav => grvity + + implicit none + + ! -- large scale wet deposition scavenging factors + + private + + public :: dep_wet_ls_init + public :: wetdep_ls + public :: WetRemovalGOCART + +contains + +! subroutine dep_wet_ls_init(config, rc) + subroutine dep_wet_ls_init(data) + implicit none + type(smoke_data), intent(inout) :: data + + ! -- I/O arguments +! type(chem_config_type), intent(in) :: config +! integer, intent(out) :: rc + + ! -- local variables + integer :: ios, n + + ! -- begin + !rc = CHEM_RC_SUCCESS + + ! -- set aerosol wet scavenging coefficients + if (associated(data%alpha)) then + deallocate(data%alpha, stat=ios) + !if (chem_rc_test((ios /= 0), msg="Failed to deallocate memory", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + end if + + allocate(data%alpha(num_chem), stat=ios) + !if (chem_rc_test((ios /= 0), msg="Failed to allocate memory", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + + data%alpha = 0. + + select case (wetdep_ls_opt) + case (WDLS_OPT_GSD) + + select case (chem_opt) + case (CHEM_OPT_GOCART) + data%alpha = 1.0 + end select + + case (WDLS_OPT_NGAC) + + select case (chem_opt) + case (CHEM_OPT_GOCART) + data%alpha(p_so2 ) = 0. + data%alpha(p_sulf ) = 1.5 + data%alpha(p_dms ) = 0. + data%alpha(p_msa ) = 0. + data%alpha(p_p25 ) = 1. + data%alpha(p_bc1 ) = 0.7 + data%alpha(p_bc2 ) = 0.7 + data%alpha(p_oc1 ) = 1. + data%alpha(p_oc2 ) = 1. + data%alpha(p_dust_1) = 1. + data%alpha(p_dust_2) = 1. + data%alpha(p_dust_3) = 1. + data%alpha(p_dust_4) = 1. + data%alpha(p_dust_5) = 1. + data%alpha(p_seas_1) = 1. + data%alpha(p_seas_2) = 1. + data%alpha(p_seas_3) = 1. + data%alpha(p_seas_4) = 1. + data%alpha(p_seas_5) = 1. + data%alpha(p_p10 ) = 1. + case default + ! -- NGAC large scale wet deposition only works with GOCART + end select + + case default + end select + + ! -- replace first default wet scavenging coefficients with input values if + ! available + if (any(wetdep_ls_alpha > 0._kind_phys)) then + n = min(size(data%alpha), size(wetdep_ls_alpha)) + data%alpha(1:n) = real(wetdep_ls_alpha(1:n)) + end if + + end subroutine dep_wet_ls_init + + + + subroutine wetdep_ls(data,dt,var,rain,moist,rho,var_rmv, & + num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN ) :: num_chem,num_moist,p_qc, p_qi, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(kind_phys), INTENT(IN ) :: dt + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: rho,dz8w,vvel + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem), & + INTENT(INOUT) :: var + REAL(kind_phys), DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: rain + REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & + INTENT(INOUT ) :: var_rmv + REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: var_sum + REAL(kind_phys), DIMENSION( its:ite , kts:kte, jts:jte ) :: var_rmvl + REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: frc,var_sum_clw,rain_clw + real(kind_phys) :: dvar,factor,rho_water + integer :: nv,i,j,k + + rho_water = 1000. + var_rmv (:,:,:)=0. + + do nv=1,num_chem +! +! simple LS removal +! + +! +! proportionality constant +! + frc(:,:)=0.1 + do i=its,ite + do j=jts,jte + var_sum_clw(i,j)=0. + var_sum(i,j)=0. + var_rmvl(i,:,j)=0. + rain_clw(i,j)=0. + if(rain(i,j).gt.1.e-6)then +! convert rain back to rate +! + rain_clw(i,j)=rain(i,j)/dt +! total cloud water +! + do k=1,kte + dvar=max(0.,(moist(i,k,j,p_qc)+moist(i,k,j,p_qi))) + var_sum_clw(i,j)=var_sum_clw(i,j)+dvar + enddo + endif + enddo + enddo +! +! get rid of it +! + do i=its,ite + do j=jts,jte + if(rain(i,j).gt.1.e-6 .and. var_sum_clw(i,j).gt.1.e-10 ) then + do k=kts,kte + if(var(i,k,j,nv).gt.1.e-08 .and. (moist(i,k,j,p_qc)+moist(i,k,j,p_qi)).gt.1.e-8)then + factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) + dvar=max(0.,data%alpha(nv)*factor/(1+factor)*var(i,k,j,nv)) + dvar=min(dvar,var(i,k,j,nv)) + var_rmvl(i,k,j)=dvar + if((var(i,k,j,nv)-dvar).lt.1.e-16)then + dvar=var(i,k,j,nv)-1.e-16 + var_rmvl(i,k,j)=dvar !lzhang + var(i,k,j,nv)=var(i,k,j,nv)-dvar + else + var(i,k,j,nv)=var(i,k,j,nv)-dvar + endif + !var_rmv(i,j,nv)=var_rmv(i,j,nv)+var_rmvl(i,k,j) + !!convert wetdeposition into ug/m2/s + var_rmv(i,j,nv)=var_rmv(i,j,nv)+(var_rmvl(i,k,j)*rho(i,k,j)*dz8w(i,k,j)/dt) !lzhang + endif + enddo + var_rmv(i,j,nv)=max(0.,var_rmv(i,j,nv)) + endif + enddo + enddo + enddo + + end subroutine wetdep_ls + +!------------------------------------------------------------------------- +! NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3 ! +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: WetRemovalGOCART - Calculate aerosol wet removal due +! to large scale processes. +! +! !INTERFACE: +! + + subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & + num_chem, var_rmv, chem, ple, tmpu, & + rhoa, dqcond, precc, precl, & + ims, ime, jms, jme, kms, kme) +! ims, ime, jms, jme, kms, kme, rc ) + +! !USES: + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! !INPUT PARAMETERS: + integer, intent(in) :: i1, i2, j1, j2, k1, k2, n1, n2, num_chem, & + ims, ime, jms, jme, kms, kme + real(kind_phys), intent(in) :: cdt + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem),& + INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & + INTENT(INOUT ) :: var_rmv !! tracer loss flux [kg m-2 s-1] + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme),& + INTENT(IN) :: ple, tmpu, rhoa, dqcond + real(kind_phys), dimension(ims:ime , jms:jme) , & + INTENT(IN) :: precc, precl ! cv, ls precip [mm day-1] + +! !OUTPUT PARAMETERS: +! integer, intent(out) :: rc ! Error return code: + ! 0 - all is well + ! 1 - + +! !DESCRIPTION: Calculates the updated species concentration due to wet +! removal. As written, intended to function for large +! scale (not convective) wet removal processes + +! +! !REVISION HISTORY: +! +! 08Jan2010 - Colarco, based on GOCART implementation, does not +! include any size dependent term +! +!EOP +!------------------------------------------------------------------------- + +! !Local Variables + character(len=*), parameter :: myname = 'WetRemovalGOCART' + integer :: i, j, k, n, nbins, LH, kk, ios,nv + real(kind_phys) :: pdog(i1:i2,k1:k2,j1:j2) ! air mass factor dp/g [kg m-2] + real(kind_phys) :: pls, pcv, pac ! ls, cv, tot precip [mm day-1] + real(kind_phys) :: qls(k1:k2), qcv(k1:k2) ! ls, cv portion dqcond [kg m-3 s-1] + real(kind_phys) :: qmx, qd, A ! temporary variables on moisture + real(kind_phys) :: F, B, BT ! temporary variables on cloud, freq. + real(kind_phys), allocatable :: fd(:,:) ! flux across layers [kg m-2] + real(kind_phys), allocatable :: DC(:) ! scavenge change in mass mixing ratio +! Rain parameters from Liu et al. + real(kind_phys), parameter :: B0_ls = 1.0e-4 + real(kind_phys), parameter :: F0_ls = 1.0 + real(kind_phys), parameter :: XL_ls = 5.0e-4 + real(kind_phys), parameter :: B0_cv = 1.5e-3 + real(kind_phys), parameter :: F0_cv = 0.3 + real(kind_phys), parameter :: XL_cv = 2.0e-3 +! Duration of rain: ls = model timestep, cv = 1800 s (<= cdt) + real(kind_phys) :: Td_ls + real(kind_phys) :: Td_cv + + +! Efficiency of dust wet removal (since dust is really not too hygroscopic) +! Applied only to in-cloud scavenging + real(kind_phys) :: effRemoval +! real(kind_phys),dimension(20) ::fwet +! tracer: p_so2=1 p_sulf=2 p_dms=3 p_msa=4 p_p25=5 p_bc1=6 p_bc2=7 p_oc1=8 +! p_oc2=9 p_dust_1=10 p_dust_2=11 p_dust_3=12 p_dust_4=13 p_dust_5=14 +! p_seas_1=15 p_seas_2=16 p_seas_3=17 p_seas_4=18 p_seas_5=19 p_p10 =20 +! data fwet /0.,1.5,0.,0.,1.,0.7,0.7,0.4,0.4,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1./ +! rc=0. + +! Initialize local variables +! -------------------------- +! rc = CHEM_RC_SUCCESS + + Td_ls = cdt + Td_cv = cdt + nbins = n2-n1+1 + var_rmv = 0.0 + +! Allocate the dynamic arrays + allocate(fd(k1:k2,nbins),stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + allocate(dc(nbins),stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + +! Accumulate the 3-dimensional arrays of rhoa and pdog + do j = j1, j2 + do i = i1, i2 + !pdog(i,k1:k2,j) = (ple(i,k1+1:k2+1,j)-ple(i,k1:k2,j)) / grav + pdog(i,k1:k2,j) = (ple(i,k1:k2,j)-ple(i,k1+1:k2+1,j)) / grav !lzhang + enddo + enddo + + do nv=1, num_chem +! Loop over spatial indices + do j = j1, j2 + do i = i1, i2 + +! Check for total precipitation amount +! Assume no precip in column if precl+precc = 0 + pac = precl(i,j) + precc(i,j) + if(pac .le. 0.) goto 100 + pls = precl(i,j) + pcv = precc(i,j) + +! Initialize the precipitation fields + qls(:) = 0. + qcv(:) = 0. + fd(:,:) = 0. + +! Find the highest model layer experiencing rainout. Assumes no +! scavenging if T < 258 K + !LH = 0 + LH = k2+1 !lzhang + !do k = k1, k2 + do k = k2, k1,-1 !lzhang + if(dqcond(i,k,j) .lt. 0. .and. tmpu(i,k,j) .gt. 258.) then + LH = k + goto 15 + endif + end do + 15 continue + !if(LH .lt. 1) goto 100 + if(LH .gt. k2) goto 100 !lzhang + +! convert dqcond from kg water/kg air/s to kg water/m3/s and reverse +! sign so that dqcond < 0. (positive precip) means qls and qcv > 0. + !do k = LH, k2 + do k = LH, k1, -1 !lzhang + qls(k) = -dqcond(i,k,j)*pls/pac*rhoa(i,k,j) + qcv(k) = -dqcond(i,k,j)*pcv/pac*rhoa(i,k,j) + end do + +! Loop over vertical to do the scavenging! + !do k = LH, k2 + do k = LH, k1, -1 !lzhang + +!----------------------------------------------------------------------------- +! (1) LARGE-SCALE RAINOUT: +! Tracer loss by rainout = TC0 * F * exp(-B*dt) +! where B = precipitation frequency, +! F = fraction of grid box covered by precipitating clouds. +! We assume that tracer scavenged by rain is falling down to the +! next level, where a fraction could be re-evaporated to gas phase +! if Qls is less then 0 in that level. +!----------------------------------------------------------------------------- + if (qls(k) .gt. 0.) then + F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(qls(k)*cdt/Td_ls)) + B = B0_ls/F0_ls +1./(F0_ls*XL_ls/qls(k)) + BT = B * Td_ls + if (BT.gt.10.) BT = 10. !< Avoid overflow > +! Adjust du level: + do n = 1, nbins + effRemoval = data%alpha(nv) + DC(n) = chem(i,k,j,nv) * F * effRemoval *(1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 + end do +! Flux down: unit is kg m-2 +! Formulated in terms of production in the layer. In the revaporation step +! we consider possibly adding flux from above... + do n = 1, nbins + Fd(k,n) = DC(n)*pdog(i,k,j) + end do + + end if ! if Qls > 0 >>> + +!----------------------------------------------------------------------------- +! * (2) LARGE-SCALE WASHOUT: +! * Occurs when rain at this level is less than above. +!----------------------------------------------------------------------------- + !if(k .gt. LH .and. qls(k) .ge. 0.) then + if(k .lt. LH .and. qls(k) .ge. 0.) then !lzhang + !if(qls(k) .lt. qls(k-1)) then + if(qls(k) .lt. qls(k+1)) then !lzhang +! Find a maximum F overhead until the level where Qls<0. + Qmx = 0. + !do kk = k-1,LH,-1 + do kk = k+1,LH !lzhang + if (Qls(kk).gt.0.) then + Qmx = max(Qmx,Qls(kk)) + else + goto 333 + end if + end do + + 333 continue + F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(Qmx*cdt/Td_ls)) + if (F.lt.0.01) F = 0.01 +!----------------------------------------------------------------------------- +! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order +! to use the Harvard formula. Convert back to mixing ratio by multiplying +! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density +! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives +! units of mm/s (omit the multiply and divide by 1000). +!----------------------------------------------------------------------------- + + Qd = Qmx /rhoa(i,k,j)*pdog(i,k,j) + if (Qd.ge.50.) then + B = 0. + else + B = Qd * 0.1 + end if + BT = B * cdt + if (BT.gt.10.) BT = 10. + +! Adjust du level: + do n = 1, nbins + DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) & + chem(i,k,j,nv) = 1.0E-32 + var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s + end do + + end if + end if ! if ls washout >>> +#if 0 +!----------------------------------------------------------------------------- +! (3) CONVECTIVE RAINOUT: +! Tracer loss by rainout = dd0 * F * exp(-B*dt) +! where B = precipitation frequency, +! F = fraction of grid box covered by precipitating clouds. +!----------------------------------------------------------------------------- + + if (qcv(k) .gt. 0.) then + F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qcv(k)*cdt/Td_cv)) + B = B0_cv + BT = B * Td_cv + if (BT.gt.10.) BT = 10. !< Avoid overflow > + +! Adjust du level: + do n = 1, nbins + effRemoval = data%alpha(nv) + DC(n) = chem(i,k,j,nv) * F * effRemoval * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 + end do + +!------ Flux down: unit is kg. Including both ls and cv. + do n = 1, nbins + Fd(k,n) = Fd(k,n) + DC(n)*pdog(i,k,j) + end do + + end if ! if Qcv > 0 >>> + +!----------------------------------------------------------------------------- +! (4) CONVECTIVE WASHOUT: +! Occurs when rain at this level is less than above. +!----------------------------------------------------------------------------- + + !if (k.gt.LH .and. Qcv(k).ge.0.) then + if (k.lt.LH .and. Qcv(k).ge.0.) then !lzhang + !if (Qcv(k).lt.Qcv(k-1)) then + if (Qcv(k).lt.Qcv(k+1)) then !lzhang +!----- Find a maximum F overhead until the level where Qls<0. + Qmx = 0. + !do kk = k-1, LH, -1 + do kk = k+1, LH !lzhang + if (Qcv(kk).gt.0.) then + Qmx = max(Qmx,Qcv(kk)) + else + goto 444 + end if + end do + + 444 continue + F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qmx*cdt/Td_cv)) + if (F.lt.0.01) F = 0.01 +!----------------------------------------------------------------------------- +! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order +! to use the Harvard formula. Convert back to mixing ratio by multiplying +! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density +! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives +! units of mm/s (omit the multiply and divide by 1000). +!----------------------------------------------------------------------------- + + Qd = Qmx / rhoa(i,k,j)*pdog(i,k,j) + if (Qd.ge.50.) then + B = 0. + else + B = Qd * 0.1 + end if + BT = B * cdt + if (BT.gt.10.) BT = 10. + +! Adjust du level: + do n = 1, nbins + DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) + if (DC(n).lt.0.) DC(n) = 0. + chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) + if (chem(i,k,j,nv) .lt. 1.0E-32) & + chem(i,k,j,nv) = 1.0E-32 + var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s + end do + + end if + end if ! if cv washout >>> +#endif +!----------------------------------------------------------------------------- +! (5) RE-EVAPORATION. Assume that SO2 is re-evaporated as SO4 since it +! has been oxidized by H2O2 at the level above. +!----------------------------------------------------------------------------- +! Add in the flux from above, which will be subtracted if reevaporation occurs + !if(k .gt. LH) then + if(k .lt. LH) then !lzhang + do n = 1, nbins + !Fd(k,n) = Fd(k,n) + Fd(k-1,n) + Fd(k,n) = Fd(k,n) + Fd(k+1,n) !lzhang + end do + +! Is there evaporation in the currect layer? + if (-dqcond(i,k,j) .lt. 0.) then +! Fraction evaporated = H2O(k)evap / H2O(next condensation level). + !if (-dqcond(i,k-1,j) .gt. 0.) then + if (-dqcond(i,k+1,j) .gt. 0.) then !lzhang + + A = abs( dqcond(i,k,j) * pdog(i,k,j) & + !/ ( dqcond(i,k-1,j) * pdog(i,k-1,j)) ) + / ( dqcond(i,k+1,j) * pdog(i,k+1,j)) ) !lzhang + if (A .gt. 1.) A = 1. + +! Adjust tracer in the level + do n = 1, nbins + !DC(n) = Fd(k-1,n) / pdog(i,k,j) * A + DC(n) = Fd(k+1,n) / pdog(i,k,j) * A !lzhang + chem(i,k,j,nv) = chem(i,k,j,nv) + DC(n) + chem(i,k,j,nv) = max(chem(i,k,j,nv),1.e-32) +! Adjust the flux out of the bottom of the layer + Fd(k,n) = Fd(k,n) - DC(n)*pdog(i,k,j) + end do + + endif + endif ! if -moistq < 0 + endif + end do ! k + + do n = 1, nbins + !var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k2,n)/cdt !lzhang + var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k1,n)/cdt ! ug/m2/s + end do + + 100 continue + end do ! i + end do ! j + end do !nv for num_chem + + deallocate(fd,DC,stat=ios) +! if (chem_rc_test((ios .ne. 0), msg="Failed to deallocate memory", & +! file=__FILE__, line=__LINE__, rc=rc)) return + + end subroutine WetRemovalGOCART + +end module dep_wet_ls_mod diff --git a/smoke/dust_data_mod.F90 b/smoke/dust_data_mod.F90 new file mode 100755 index 000000000..33767701b --- /dev/null +++ b/smoke/dust_data_mod.F90 @@ -0,0 +1,108 @@ +module dust_data_mod + + use rrfs_smoke_data + use machine , only : kind_phys + use rrfs_smoke_config, only : p_dust_1, p_dust_2, p_dust_3, p_dust_4, p_dust_5, & + p_edust1, p_edust2, p_edust3, p_edust4, p_edust5 + + + implicit none + + integer, parameter :: ndust = 5 + integer, parameter :: ndcls = 3 + integer, parameter :: ndsrc = 1 + integer, parameter :: maxstypes = 100 + integer, parameter :: nsalt = 9 + + real(kind_phys), parameter :: dyn_visc = 1.5E-5 + + ! -- dust parameters + ! never used: integer, dimension(ndust), parameter :: ipoint = (/ 3, 2, 2, 2, 2 /) + real(kind_phys), dimension(ndust), parameter :: den_dust = (/ 2500., 2650., 2650., 2650., 2650. /) + real(kind_phys), dimension(ndust), parameter :: reff_dust = (/ 0.73D-6, 1.4D-6, 2.4D-6, 4.5D-6, 8.0D-6 /) + real(kind_phys), dimension(ndust), parameter :: frac_s = (/ 0.1, 0.25, 0.25, 0.25, 0.25 /) + real(kind_phys), dimension(ndust), parameter :: lo_dust = (/ 0.1D-6, 1.0D-6, 1.8D-6, 3.0D-6, 6.0D-6 /) + real(kind_phys), dimension(ndust), parameter :: up_dust = (/ 1.0D-6, 1.8D-6, 3.0D-6, 6.0D-6,10.0D-6 /) + ! never used: real(kind_phys), dimension(ndust, 12) :: ch_dust = 0.8e-09_kind_phys + + ! -- default dust parameters + ! -- AFWA & GOCART + ! -----------+----------+-----------+ + ! Parameter | FIM-Chem | HRRR-Chem | + ! -----------+----------+-----------+ + ! alpha | 1.0 | 0.5 | + ! gamma | 1.6 | 1.0 | + ! -----------+----------+-----------+ + ! Never used: + ! real(kind_phys), parameter :: afwa_alpha = 0.2 + ! real(kind_phys), parameter :: afwa_gamma = 1.3 + ! real(kind_phys), parameter :: gocart_alpha = 0.3 + ! real(kind_phys), parameter :: gocart_gamma = 1.3 + ! -- FENGSHA + ! Never used: + ! real(kind_phys), parameter :: fengsha_alpha = 0.3 + ! real(kind_phys), parameter :: fengsha_gamma = 1.3 + ! -- FENGSHA threshold velocities based on Dale A. Gillette's data + integer, parameter :: fengsha_maxstypes = 13 +! real(kind_phys), dimension(fengsha_maxstypes) :: dust_uthres = & +! (/ 0.065, & ! Sand - 1 +! 0.20, & ! Loamy Sand - 2 +! 0.52, & ! Sandy Loam - 3 +! 0.50, & ! Silt Loam - 4 +! 0.50, & ! Silt - 5 +! 0.60, & ! Loam - 6 +! 0.73, & ! Sandy Clay Loam - 7 +! 0.73, & ! Silty Clay Loam - 8 +! 0.80, & ! Clay Loam - 9 +! 0.95, & ! Sandy Clay - 10 +! 0.95, & ! Silty Clay - 11 +! 1.00, & ! Clay - 12 +! 9.999 /) ! Other - 13 +! dust_uthres = 0.065, 0.18, 0.27, 0.30, 0.35, 0.38, 0.35, 0.41, 0.41, +! 0.45,0.50,0.45,9999.0 + real(kind_phys), dimension(fengsha_maxstypes), parameter :: dust_uthres = & + (/ 0.065, & ! Sand - 1 + 0.18, & ! Loamy Sand - 2 + 0.27, & ! Sandy Loam - 3 + 0.30, & ! Silt Loam - 4 + 0.35, & ! Silt - 5 + 0.38, & ! Loam - 6 + 0.35, & ! Sandy Clay Loam - 7 + 0.41, & ! Silty Clay Loam - 8 + 0.41, & ! Clay Loam - 9 + 0.45, & ! Sandy Clay - 10 + 0.50, & ! Silty Clay - 11 + 0.45, & ! Clay - 12 + 9999.0 /) ! Other - 13 + ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015) + integer, parameter :: dust_calcdrag = 1 + + real(kind_phys), parameter :: dust_alpha = 2.2 + real(kind_phys), parameter :: dust_gamma = 1.0 + + + ! -- sea salt parameters + integer, dimension(nsalt), parameter :: spoint = (/ 1, 2, 2, 2, 2, 2, 3, 3, 3 /) ! 1 Clay, 2 Silt, 3 Sand + real(kind_phys), dimension(nsalt), parameter :: reff_salt = & + (/ 0.71D-6, 1.37D-6, 2.63D-6, 5.00D-6, 9.50D-6, 18.1D-6, 34.5D-6, 65.5D-6, 125.D-6 /) + real(kind_phys), dimension(nsalt), parameter :: den_salt = & + (/ 2500., 2650., 2650., 2650., 2650., 2650., 2650., 2650., 2650. /) + real(kind_phys), dimension(nsalt), parameter :: frac_salt = & + (/ 1., 0.2, 0.2, 0.2, 0.2, 0.2, 0.333, 0.333, 0.333 /) + + + ! -- soil vagatation parameters + integer, parameter :: max_soiltyp = 30 + real(kind_phys), dimension(max_soiltyp), parameter :: & + maxsmc = (/ 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, & + 0.404, 0.439, 0.421, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 /) + + ! -- other soil parameters + ! never used: real(kind_phys), dimension(maxstypes) :: porosity + + public + +end module dust_data_mod diff --git a/smoke/dust_fengsha_mod.F90 b/smoke/dust_fengsha_mod.F90 new file mode 100755 index 000000000..c43719386 --- /dev/null +++ b/smoke/dust_fengsha_mod.F90 @@ -0,0 +1,598 @@ +module dust_fengsha_mod +! +! This module developed by Barry Baker (NOAA ARL) +! For serious questions contact barry.baker@noaa.gov +! +! 07/16/2019 - Adapted for NUOPC/GOCART, R. Montuoro +! 02/01/2020 - Adapted for FV3/CCPP, Haiqin Li + + use rrfs_smoke_data + use machine , only : kind_phys + use dust_data_mod + + implicit none + + private + + public :: gocart_dust_fengsha_driver + +contains + + subroutine gocart_dust_fengsha_driver(data, dt, & + chem,rho_phy,smois,p8w,ssm, & + isltyp,vegfra,snowh,xland,area,g,emis_dust, & + ust,znt,clay,sand,rdrag,uthr, & + num_emis_dust,num_moist,num_chem,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + num_emis_dust,num_moist,num_chem,num_soil_layers + INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, INTENT(INOUT) :: emis_dust + REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra, & + snowh, & + xland, & + area, & + ust, & + znt, & + clay, & + sand, & + rdrag, & + uthr + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & + p8w, & + rho_phy + REAL(kind_phys), INTENT(IN) :: dt,g + + ! Local variables + + integer :: nmx,smx,i,j,k,imx,jmx,lmx + integer,dimension (1,1) :: ilwi + real(kind_phys), DIMENSION (1,1) :: erodtot + REAL(kind_phys), DIMENSION (1,1) :: gravsm + REAL(kind_phys), DIMENSION (1,1) :: drylimit + real(kind_phys), DIMENSION (5) :: tc,bems + real(kind_phys), dimension (1,1) :: airden,airmas,ustar + real(kind_phys), dimension (1) :: dxy + real(kind_phys), dimension (3) :: massfrac + real(kind_phys) :: conver,converi + real(kind_phys) :: R + + ! threshold values + conver=1.e-9 + converi=1.e9 + + ! Number of dust bins + + imx=1 + jmx=1 + lmx=1 + nmx=ndust + smx=nsalt + + k=kts + do j=jts,jte + do i=its,ite + + ! Don't do dust over water!!! + + ilwi(1,1)=0 + if(xland(i,j).lt.1.5)then + ilwi(1,1)=1 + + ! Total concentration at lowest model level. This is still hardcoded for 5 bins. + + ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then + ! tc(:)=1.e-16*conver + ! else + tc(1)=chem(i,kts,j,p_dust_1)*conver + tc(2)=chem(i,kts,j,p_dust_2)*conver + tc(3)=chem(i,kts,j,p_dust_3)*conver + tc(4)=chem(i,kts,j,p_dust_4)*conver + tc(5)=chem(i,kts,j,p_dust_5)*conver + ! endif + + ! Air mass and density at lowest model level. + + airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g + airden(1,1)=rho_phy(i,kts,j) + ustar(1,1)=ust(i,j) + dxy(1)=area(i,j) + + ! Mass fractions of clay, silt, and sand. + massfrac(1)=clay(i,j) + massfrac(2)=1-(clay(i,j)+sand(i,j)) + massfrac(3)=sand(i,j) + + + ! Total erodibility. + + erodtot(1,1) = ssm(i,j) ! SUM(erod(i,j,:)) + + ! Don't allow roughness lengths greater than 20 cm to be lofted. + ! This kludge accounts for land use types like urban areas and + ! forests which would otherwise show up as high dust emitters. + ! This is a placeholder for a more widely accepted kludge + ! factor in the literature, which reduces lofting for rough areas. + ! Forthcoming... + + IF (znt(i,j) .gt. 0.2) then + ilwi(1,1)=0 + endif + + ! limit where there is lots of vegetation + if (vegfra(i,j) .gt. .17) then + ilwi(1,1) = 0 + endif + + ! limit where there is snow on the ground + if (snowh(i,j) .gt. 0) then + ilwi(1,1) = 0 + endif + + ! Do not allow areas with bedrock, lava, or land-ice to loft + + IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & + isltyp(i,j) .eq. 18) then + ilwi(1,1)=0 + ENDIF + IF (isltyp(i,j) .eq. 0)then + ilwi(1,1)=0 + endif + if(ilwi(1,1) == 0 ) cycle + + ! Calculate gravimetric soil moisture and drylimit. + gravsm(1,1)=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) + drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) + + ! get drag partition + ! FENGSHA uses the drag partition correction of MacKinnon et al 2004 + ! doi:10.1016/j.geomorph.2004.03.009 + if (dust_calcdrag .ne. 1) then + call fengsha_drag(data,znt(i,j),R) + else + ! use the precalculated version derived from ASCAT; Prigent et al. (2012,2015) + ! doi:10.1109/TGRS.2014.2338913 & doi:10.5194/amt-5-2703-2012 + ! pick only valid values + if (rdrag(i,j) > 0.) then + R = real(rdrag(i,j), kind=kind_phys) + else + cycle + endif + endif + + ! Call dust emission routine. + call source_dust(data, imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & + erodtot, dxy, gravsm, airden, airmas, & + bems, g, drylimit, dust_alpha, dust_gamma, R, uthr(i,j)) + + ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then + ! dustin(i,j,1:5)=tc(1:5)*converi + ! else + chem(i,kts,j,p_dust_1)=tc(1)*converi + chem(i,kts,j,p_dust_2)=tc(2)*converi + chem(i,kts,j,p_dust_3)=tc(3)*converi + chem(i,kts,j,p_dust_4)=tc(4)*converi + chem(i,kts,j,p_dust_5)=tc(5)*converi + ! endif + + ! chem(i,kts,j,p_dust_1)=tc(1)*converi + ! chem(i,kts,j,p_dust_2)=tc(2)*converi + ! chem(i,kts,j,p_dust_3)=tc(3)*converi + ! chem(i,kts,j,p_dust_4)=tc(4)*converi + ! chem(i,kts,j,p_dust_5)=tc(5)*converi + + ! For output diagnostics + + emis_dust(i,1,j,p_edust1)=bems(1) + emis_dust(i,1,j,p_edust2)=bems(2) + emis_dust(i,1,j,p_edust3)=bems(3) + emis_dust(i,1,j,p_edust4)=bems(4) + emis_dust(i,1,j,p_edust5)=bems(5) + endif + enddo + enddo + ! + + end subroutine gocart_dust_fengsha_driver + + + SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & + erod, dxy, gravsm, airden, airmas, bems, g0, drylimit, alpha, & + gamma, R, uthres) + + ! **************************************************************************** + ! * Evaluate the source of each dust particles size bin by soil emission + ! * + ! * Input: + ! * EROD Fraction of erodible grid cell (-) + ! * GRAVSM Gravimetric soil moisture (g/g) + ! * DRYLIMIT Upper GRAVSM limit for air-dry soil (g/g) + ! * ALPHA Constant to fudge the total emission of dust (1/m) + ! * GAMMA Tuning constant for erodibility (-) + ! * DXY Surface of each grid cell (m2) + ! * AIRMAS Mass of air for each grid box (kg) + ! * AIRDEN Density of air for each grid box (kg/m3) + ! * USTAR Friction velocity (m/s) + ! * DT1 Time step (s) + ! * NMX Number of dust bins (-) + ! * SMX Number of saltation bins (-) + ! * IMX Number of I points (-) + ! * JMX Number of J points (-) + ! * LMX Number of L points (-) + ! * R Drag Partition (-) + ! * UTHRES FENGSHA Dry Threshold Velocities (m/s) + ! * + ! * Data: + ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) + ! * SPOINT Pointer to 3 soil classes (-) + ! * DEN_DUST Dust density (kg/m3) + ! * DEN_SALT Saltation particle density (kg/m3) + ! * REFF_SALT Reference saltation particle diameter (m) + ! * REFF_DUST Reference dust particle diameter (m) + ! * LO_DUST Lower diameter limits for dust bins (m) + ! * UP_DUST Upper diameter limits for dust bins (m) + ! * FRAC_SALT Soil class mass fraction for saltation bins (-) + ! * + ! * Parameters: + ! * CMB Constant of proportionality (-) + ! * MMD_DUST Mass median diameter of dust (m) + ! * GSD_DUST Geometric standard deviation of dust (-) + ! * LAMBDA Side crack propagation length (m) + ! * CV Normalization constant (-) + ! * G0 Gravitational acceleration (m/s2) + ! * G Gravitational acceleration in cgs (cm/s2) + ! * + ! * Working: + ! * U_TS0 "Dry" threshold friction velocity (m/s) + ! * U_TS Moisture-adjusted threshold friction velocity (m/s) + ! * RHOA Density of air in cgs (g/cm3) + ! * DEN Dust density in cgs (g/cm3) + ! * DIAM Dust diameter in cgs (cm) + ! * DMASS Saltation mass distribution (-) + ! * DSURFACE Saltation surface area per unit mass (m2/kg) + ! * DS_REL Saltation surface area distribution (-) + ! * SALT Saltation flux (kg/m/s) + ! * DLNDP Dust bin width (-) + ! * EMIT Total vertical mass flux (kg/m2/s) + ! * EMIT_VOL Total vertical volume flux (m/s) + ! * DSRC Mass of emitted dust (kg/timestep/cell) + ! * + ! * Output: + ! * TC Total concentration of dust (kg/kg/timestep/cell) + ! * BEMS Source of each dust type (kg/timestep/cell) + ! * + ! **************************************************************************** + implicit none + type(smoke_data), intent(inout) :: data + + INTEGER, INTENT(IN) :: imx,jmx,lmx,nmx,smx + REAL(kind_phys), INTENT(IN) :: dt1 + REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) + REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx) + REAL(kind_phys), INTENT(IN) :: massfrac(3) + REAL(kind_phys), INTENT(IN) :: erod(imx,jmx) + REAL(kind_phys), INTENT(IN) :: dxy(jmx) + REAL(kind_phys), INTENT(IN) :: gravsm(imx,jmx) + REAL(kind_phys), INTENT(IN) :: airden(imx,jmx,lmx) + REAL(kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) + REAL(kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) + REAL(kind_phys), INTENT(IN) :: g0 + REAL(kind_phys), INTENT(IN) :: drylimit(imx,jmx) + !! Sandblasting mass efficiency, aka "fudge factor" (based on Tegen et al, + !! 2006 and Hemold et al, 2007) + ! + ! REAL, PARAMETER :: alpha=1.8E-8 ! (m^-1) + REAL(kind_phys), INTENT(IN) :: alpha + ! Experimental optional exponential tuning constant for erodibility. + ! 0 < gamma < 1 -> more relative impact by low erodibility regions. + REAL(kind_phys), INTENT(IN) :: gamma + REAL(kind_phys), INTENT(IN) :: R + REAL(kind_phys), INTENT(IN) :: uthres + + REAL(kind_phys) :: den(smx), diam(smx) + REAL(kind_phys) :: dvol(nmx), distr_dust(nmx), dlndp(nmx) + REAL(kind_phys) :: dsurface(smx), ds_rel(smx) + REAL(kind_phys) :: u_ts0, u_ts, dsrc, dmass, dvol_tot + REAL(kind_phys) :: salt,emit, emit_vol, stotal + REAL(kind_phys) :: rhoa, g + INTEGER :: i, j, n + + ! Sandblasting mass efficiency, beta. + ! Beta maxes out for clay fractions above 0.2 = betamax. + + REAL(kind_phys), PARAMETER :: betamax=5.25E-4 + REAL(kind_phys) :: beta + integer :: styp + + ! Constant of proportionality from Marticorena et al, 1997 (unitless) + ! Arguably more ~consistent~ fudge than alpha, which has many walnuts + ! sprinkled throughout the literature. - GC + + REAL(kind_phys), PARAMETER :: cmb=1.0 + ! REAL, PARAMETER :: cmb=2.61 ! from White,1979 + + ! Parameters used in Kok distribution function. Advise not to play with + ! these without the expressed written consent of someone who knows what + ! they're doing. - GC + + REAL(kind_phys), PARAMETER :: mmd_dust=3.4D-6 ! median mass diameter (m) + REAL(kind_phys), PARAMETER :: gsd_dust=3.0 ! geom. std deviation + REAL(kind_phys), PARAMETER :: lambda=12.0D-6 ! crack propagation length (m) + REAL(kind_phys), PARAMETER :: cv=12.62D-6 ! normalization constant + + ! Calculate saltation surface area distribution from sand, silt, and clay + ! mass fractions and saltation bin fraction. This will later become a + ! modifier to the total saltation flux. The reasoning here is that the + ! size and availability of saltators affects saltation efficiency. Based + ! on Eqn. (32) in Marticorena & Bergametti, 1995 (hereon, MB95). + + DO n=1,smx + dmass=massfrac(spoint(n))*frac_salt(n) + dsurface(n)=0.75*dmass/(den_salt(n)*reff_salt(n)) + ENDDO + + ! The following equation yields relative surface area fraction. It will only + ! work if you are representing the "full range" of all three soil classes. + ! For this reason alone, we have incorporated particle sizes that encompass + ! the clay class, to account for the its relative area over the basal + ! surface, even though these smaller bins would be unlikely to play any large + ! role in the actual saltation process. - GC + + stotal=SUM(dsurface(:)) + DO n=1,smx + ds_rel(n)=dsurface(n)/stotal + ENDDO + + ! Calculate total dust emission due to saltation of sand sized particles. + ! Begin by calculating DRY threshold friction velocity (u_ts0). Next adjust + ! u_ts0 for moisture to get threshold friction velocity (u_ts). Then + ! calculate saltation flux (salt) where ustar has exceeded u_ts. Finally, + ! calculate total dust emission (tot_emit), taking into account erodibility. + + ! Set DRY threshold friction velocity to input value + u_ts0 = uthres + + g = g0*1.0E2 + emit=0.0 + + DO n = 1, smx + den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) + diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) + DO i = 1,imx + DO j = 1,jmx + rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) + + ! FENGSHA uses the 13 category soil type from the USDA + ! call calc_fengsha_styp(massfrac(1),massfrac(3),massfrac(2),styp) + ! Fengsha uses threshold velocities based on dale gilletes data + ! call fengsha_utst(styp,uthres,u_ts0) + + ! Friction velocity threshold correction function based on physical + ! properties related to moisture tension. Soil moisture greater than + ! dry limit serves to increase threshold friction velocity (making + ! it more difficult to loft dust). When soil moisture has not reached + ! dry limit, treat as dry + + IF (gravsm(i,j) > drylimit(i,j)) THEN + u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68)) / R) + ELSE + u_ts = u_ts0 / R + END IF + + ! Calculate total vertical mass flux (note beta has units of m^-1) + ! Beta acts to tone down dust in areas with so few dust-sized particles that the + ! lofting efficiency decreases. Otherwise, super sandy zones would be huge dust + ! producers, which is generally not the case. Equation derived from wind-tunnel + ! experiments (see MB95). + + beta=10**(13.6*massfrac(1)-6.0) ! (unitless) + if (massfrac(1) <= 0.2) then + beta=10**(13.4*massfrac(1)-6.0) + else + beta = 2.E-4 + endif + + !--------------------------------------------------------------------- + ! formula of Draxler & Gillette (2001) Atmos. Environ. + ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) + ! + ! where: + ! F = vertical emission flux [g/m**2-s] + ! K = constant 2.0E-04 [1/m] + ! A = 0~3.5 mean = 2.8 (fudge factor) + ! U* = friction velocity [m/s] + ! Ut* = threshold friction velocity [m/s] + ! + !-------------------------------------------------------------------- + + IF (ustar(i,j) .gt. u_ts) then + call fengsha_hflux(data,ustar(i,j),u_ts,beta, salt) + salt = alpha * cmb * ds_rel(n) * airden(i,j,1) / g0 * salt * (erod(i,j)**gamma) * beta + else + salt = 0. + endif + ! EROD is taken into account above + emit = emit + salt + END DO + END DO + END DO + + ! Now that we have the total dust emission, distribute into dust bins using + ! lognormal distribution (Dr. Jasper Kok, in press), and + ! calculate total mass emitted over the grid box over the timestep. + ! + ! In calculating the Kok distribution, we assume upper and lower limits to each bin. + ! For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), + ! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) + ! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) + ! These may be changed within module_data_gocart_dust.F, but make sure it is + ! consistent with reff_dust values. These values were taken from the original + ! GOCART bin configuration. We use them here to calculate dust bin width, dlndp. + ! dVol is the volume distribution. You know...if you were wondering. GC + + dvol_tot=0. + DO n=1,nmx + dlndp(n)=LOG(up_dust(n)/lo_dust(n)) + dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& + EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) + dvol_tot=dvol_tot+dvol(n) + ! Convert mass flux to volume flux + !emit_vol=emit/den_dust(n) ! (m s^-1) + END DO + DO n=1,nmx + distr_dust(n)=dvol(n)/dvol_tot + !print *,"distr_dust(",n,")=",distr_dust(n) + END DO + + ! Now distribute total vertical emission into dust bins and update concentration. + + DO n=1,nmx + DO i=1,imx + DO j=1,jmx + ! Calculate total mass emitted + dsrc = emit*distr_dust(n)*dxy(j)*dt1 ! (kg) + IF (dsrc < 0.0) dsrc = 0.0 + + ! Update dust mixing ratio at first model level. + tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) ! (kg/kg) + ! bems(i,j,n) = dsrc ! diagnostic + !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) + bems(i,j,n) = 1.e+9*dsrc/(dxy(j)*dt1) ! diagnostic (ug/m2/s) !lzhang + END DO + END DO + END DO + + END SUBROUTINE source_dust + + subroutine fengsha_utst(data,styp,uth, ut) + implicit none + type(smoke_data), intent(inout) :: data + + integer, intent(in) :: styp + real(kind_phys), dimension(fengsha_maxstypes), intent(in) :: uth + real(kind_phys), intent(out) :: ut + ut = uth(styp) +! real (kind_phys) :: uth(13) = & +! (/ 0.08, & ! Sand - 1 +! 0.20, & ! Loamy Sand - 2 +! 0.30, & ! Sandy Loam - 3 +! 0.30, & ! Silt Loam - 4 +! 0.35, & ! Silt - 5 +! 0.60, & ! Loam - 6 +! 0.30, & ! Sandy Clay Loam - 7 +! 0.35, & ! Silty Clay Loam - 8 +! 0.45, & ! Clay Loam - 9 +! 0.45, & ! Sandy Clay - 10 +! 0.45, & ! Silty Clay - 11 +! 0.60, & ! Clay - 12 +! 9.999 /) ! Other - 13 + return + end subroutine fengsha_utst + + subroutine calc_fengsha_styp(data, clay, sand, silt, type) + implicit none + type(smoke_data), intent(inout) :: data + + !--------------------------------------------------------------- + ! Function: calculate soil type based on USDA definition. + ! Source: USDA soil texture calculator + ! + ! Defintion of soil types: + ! + ! + ! NOAH 1 2 3 4 5 6 7 8 9 10 11 12 + ! PX 1 2 3 4 - 5 6 7 8 9 10 11 + ! Soil "Sand" "Loamy Sand" "Sandy Loam" "Silt Loam" "Silt" "Loam" "Sandy Clay Loam" "Silt Clay Loam" "Clay Loam" "Sandy Clay" "Silty Clay" "Clay" + !--------------------------------------------------------------- + REAL(kind_phys), intent(in) :: clay, sand, silt + integer, intent(out) :: type + real(kind_phys) :: cly, snd, slt + + type = 0 + + snd = sand * 100. + cly = clay * 100. + slt = silt * 100. + if (slt+1.5*cly .lt. 15) type = 1 ! snd + if (slt+1.5*cly .ge. 15 .and.slt+1.5*cly .lt. 30) type = 2 ! loamy snd + if (cly .ge. 7 .and. cly .lt. 20 .and. snd .gt. 52 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 1) + if (cly .lt. 7 .and. slt .lt. 50 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 2) + if (slt .ge. 50 .and. cly .ge. 12 .and.cly .lt. 27 ) type = 4 ! slt loam (cond 1) + if (slt .ge. 50 .and. slt .lt. 80 .and.cly .lt. 12) type = 4 ! slt loam (cond 2) + if (slt .ge. 80 .and. cly .lt. 12) type = 5 ! slt + if (cly .ge. 7 .and. cly .lt. 27 .and.slt .ge. 28 .and. slt .lt. 50 .and.snd .le. 52) type = 6 ! loam + if (cly .ge. 20 .and. cly .lt. 35 .and.slt .lt. 28 .and. snd .gt. 45) type = 7 ! sndy cly loam + if (cly .ge. 27 .and. cly .lt. 40 .and.snd .lt. 20) type = 8 ! slt cly loam + if (cly .ge. 27 .and. cly .lt. 40 .and.snd .ge. 20 .and. snd .le. 45) type = 9 ! cly loam + if (cly .ge. 35 .and. snd .gt. 45) type = 10 ! sndy cly + if (cly .ge. 40 .and. slt .ge. 40) type = 11 ! slty cly + if (cly .ge. 40 .and. snd .le. 45 .and.slt .lt. 40) type = 12 ! clay + return + end subroutine calc_fengsha_styp + + subroutine fengsha_drag(data,z0,R) + implicit none + type(smoke_data), intent(inout) :: data + + real(kind_phys), intent(in) :: z0 + real(kind_phys), intent(out) :: R + real(kind_phys), parameter :: z0s = 1.0e-04 !Surface roughness for ideal bare surface [m] + ! ------------------------------------------------------------------------ + ! Function: Calculates the MacKinnon et al. 2004 Drag Partition Correction + ! + ! R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + ! + !-------------------------------------------------------------------------- + ! Drag partition correction. See MacKinnon et al. (2004), + ! doi:10.1016/j.geomorph.2004.03.009 + R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + + ! Drag partition correction. See Marticorena et al. (1997), + ! doi:10.1029/96JD02964 + !R = 1.0 - log(z0 / z0s) / log( 0.7 * (10./z0s) ** 0.8) + + return + end subroutine fengsha_drag + + subroutine fengsha_hflux(data,ust,utst, kvh, salt) + !--------------------------------------------------------------------- + ! Function: Calculates the Horizontal Saltation Flux, Q, and then + ! calculates the vertical flux. + ! + ! formula of Draxler & Gillette (2001) Atmos. Environ. + ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) + ! + ! where: + ! F = vertical emission flux [g/m**2-s] + ! K = constant 2.0E-04 [1/m] + ! A = 0~3.5 mean = 2.8 (fudge factor) + ! U* = friction velocity [m/s] + ! Ut* = threshold friction velocity [m/s] + ! + !-------------------------------------------------------------------- + implicit none + type(smoke_data), intent(inout) :: data + real(kind_phys), intent(in) :: ust, & ! friction velocity + utst, & ! threshold friction velocity + kvh ! vertical to horizontal mass flux ratio + + real(kind_phys), intent(out) :: salt + real(kind_phys) :: Q + Q = ust * (ust * ust - utst * utst) + salt = Q ! sdep * kvh * Q + + return + end subroutine fengsha_hflux + + +end module dust_fengsha_mod diff --git a/smoke/module_add_emiss_burn.F90 b/smoke/module_add_emiss_burn.F90 new file mode 100755 index 000000000..5d5e63b21 --- /dev/null +++ b/smoke/module_add_emiss_burn.F90 @@ -0,0 +1,223 @@ +module module_add_emiss_burn +!RAR: significantly modified for the new BB emissions + use machine , only : kind_phys + use rrfs_smoke_data + use rrfs_smoke_config +CONTAINS + subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & + chem,julday,gmt,xlat,xlong, & + !luf_igbp,lu_fire1, & + vegtype,vfrac,peak_hr, & + time_int,ebu, & ! RAR + r_q,fhist,aod3d_smoke,aod3d_dust, & + ! nwfa,nifa, & + rainc,rainnc, swdown,smoke_forecast, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! USE module_configure, only: grid_config_rec_type +! USE module_state_description + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ktau, julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: ebu + + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, rainc,rainnc,swdown, peak_hr, vfrac + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: r_q ! RAR: + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist ! RAR: + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: aod3d_smoke, aod3d_dust ! RAR: + integer, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: vegtype + + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy,rel_hum +! real(kind_phys), DIMENSION(ims:ime,1:nlcat,jms:jme), INTENT(IN) :: luf_igbp + +! real(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & +! OPTIONAL, INTENT(INOUT ) :: nwfa,nifa ! RAR: + + real(kind_phys), INTENT(IN) :: dtstep, gmt + real(kind_phys), INTENT(IN) :: time_int ! RAR: time in seconds since start of simulation + logical, INTENT(IN) :: smoke_forecast + + integer :: i,j,k,n,m + real(kind_phys) :: conv_rho, conv, ext2, dm_smoke, daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 + !real(kind_phys) :: ebumax +! CHARACTER (LEN=80) :: message + + INTEGER, PARAMETER :: kfire_max=35 ! max vertical level for BB plume rise + ! Diameters and standard deviations for emissions + ! the diameters are the volume (mass) geometric mean diameters, following MADE_SORGAM + real(kind_phys), PARAMETER :: dgvem_i= 0.08E-6 !0.03E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_i = 1.8 !1.7 + + ! *** Accumulation mode: + real(kind_phys), PARAMETER :: dgvem_j= 0.3E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_j = 2.0 + + ! *** Coarse mode + real(kind_phys), PARAMETER :: dgvem_c= 6.0E-6 ! [ m ] + real(kind_phys), PARAMETER :: sgem_c= 2.2 + real(kind_phys), PARAMETER :: pic= 3.14159 + + ! RAR: factors for getting number emissions rate from mass emissions rate following made_sorgam + real(kind_phys), PARAMETER :: fact_numn= 1.e-9*6.0/pic*exp(4.5*log(sgem_i)**2)/dgvem_i**3 ! Aitken mode + real(kind_phys), PARAMETER :: fact_numa= 1.e-9*6.0/pic*exp(4.5*log(sgem_j)**2)/dgvem_j**3 ! accumulation mode + real(kind_phys), PARAMETER :: fact_numc= 1.e-9*6.0/pic*exp(4.5*log(sgem_c)**2)/dgvem_c**3 ! coarse mode + + real(kind_phys), PARAMETER :: dens_oc_aer=1.4e3, dens_ec_aer=1.7e3 ! kg/m3 +! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, cx=2.184936* 3600, timeq_max=3600.*24. ! constants for the diurnal cycle calculations + real(kind_phys), PARAMETER :: ax1=531., cx1=7800. ! For cropland, urban and small fires +! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3200., const2=100., coef2=10.6712963e-4, cx=2.184936* 3600, timeq_max=3600.*24. + real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. ! New parameters + real(kind_phys), PARAMETER :: sc_me= 4.0, ab_me=0.5 ! m2/g, scattering and absorption efficiency for smoke + +! Parameters used for the wfa and ifa in mp physics per Trude E. (NCAR) +! Water friendly: radius: 0.04 micron, standard deviation: 1.8, kappa (for hygroscopic growth): 0.2, real index of refraction: 1.53, imaginary index of refraction: 1e-7 +! Ice friendly: radius: 0.4 micron, standard deviation: 1.8, kappa : 0.04, real index of refraction: 1.56, imaginary index of refraction: 3e-3 + + ! real, parameter :: cx = 2.184936 * 3600., rinti = 2.1813936e-8 , ax = 2000.6038 + ! bx_bburn = 20.041288 * 3600., RAR: this depends on the vegetation class, location (local time) etc. + real(kind_phys) :: timeq, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation + + timeq= gmt*3600. + real(time_int,4) + timeq= mod(timeq,timeq_max) + +! Main loops to add BB emissions + do j=jts,jte + do i=its,ite + !if( luf_igbp(i,17,j)>0.99 .OR. ebu(i,1,j,p_ebu_smoke) < 1.e-6) cycle ! no BB emissions or water pixels + if( (1.-vfrac (i,j))>0.99 .OR. ebu(i,1,j) < 1.e-6) cycle ! no BB emissions or water pixels + + ! RAR: the decrease in the BB emissions after >18 hrs of forecast, the decrease occurs at night. The decrease occurs at night. + IF (time_int>64800. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.75 ) THEN + fhist(i,j)= 0.75 + ENDIF + + IF (time_int>129600. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.5 ) THEN ! After 36 hr forecast + fhist(i,j)= 0.5 + ENDIF + + IF ( (rainc(i,j) + rainnc(i,j))>=10. .AND. fhist(i,j)>.3 ) THEN ! If it rains more than 1cm, then the BB emissions are reduced + fhist(i,j)= 0.3 + ENDIF + +! RAR: Grasslands (29% of ther western HRRR CONUS domain) probably also need to be added below, check this later +! RAR: In the HRRR CONUS domain (western part) crop 11%, 2% cropland/natural vegetation and 0.4% urban of pixels +!.OR. lu_index(i,j)==14) then ! Croplands(12), Urban and Built-Up(13), cropland/natural vegetation (14) mosaic in MODI-RUC vegetation classes +! Peak hours for the fire activity depending on the latitude +! if (xlong(i,j)<-130.) then max_ti= 24.041288* 3600. ! peak at 24 UTC, fires in Alaska +! elseif (xlong(i,j)<-100.) then max_ti= 22.041288* 3600. ! peak at 22 UTC, fires in the western US +! elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US, max_ti= 20.041288* 3600. +! else max_ti= 18.041288* 3600. +! endif + + !IF ( lu_fire1(i,j)>0.9 ) then !Ag, urban fires, bare land etc. + IF ( vegtype(i,j)==12 .or. vegtype(i,j)==13 ) then !Ag, urban fires, bare land etc. + ! these fires will have exponentially decreasing diurnal cycle, these fires decrease 55% in 2 hours, end in 5 hours + r_q(i,j) = rinti* ax1 * exp(- (time_int**2)/(cx1**2) ) + ELSE + ! RAR: Gaussian profile for wildfires + dt1= abs(timeq - peak_hr(i,j)) + dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. + dtm= MIN(dt1,dt2) + r_q(i,j) = rinti*( ax2 * exp(- dtm**2/(2.*cx2**2) ) + const2 - coef2*timeq ) + ENDIF + + r_q(i,j) = fhist(i,j)* max(0.,r_q(i,j)*timeq_max) + + !IF (swdown(i,j)<.1) THEN + ! r_q(i,j)= MIN(0.5,r_q(i,j)) ! lower BB emissions at night + !ENDIF + + !IF (.NOT. config_flags%bb_dcycle) THEN + !IF (.NOT. bb_dcycle) THEN + ! r_q(i,j)= fhist(i,j) ! no diurnal cycle + !END IF + + !IF (.NOT. smoke_forecast) THEN + r_q(i,j)= 1. + !END IF + + do k=kts,kfire_max + conv= r_q(i,j)*dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) + + ! RAR: in this case tracer_1 is fire emitted CO + ! conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + ! chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) + ebu(i,k,j,p_ebu_co)*conv_rho + +! dm_oc_bb = conv* ebu(i,k,j,p_ebu_oc) ! Assume that BB primary PM25 is mostly OC, 1.25 is OM/OC ratio +! dm_p25_bb= conv* ebu(i,k,j,p_ebu_pm25) +! dm_ec_bb = conv* ebu(i,k,j,p_ebu_bc) +! dm_smk = conv* ebu(i,k,j,p_ebu_smoke) + !IF (k==kts) THEN ! Partition takes place here to avoid double counting of smold. and flam. BB emiss. + ! C11= (1.-flam_frac(i,j))*r_q(i,j) + !ELSE + ! C11= flam_frac(i,j)*r_q(i,j) + !ENDIF + dm_smoke= conv*ebu(i,k,j) +! print*,'hli dm_smoke',dm_smoke,conv,ebu(i,k,j,p_ebu_smoke) + + chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke + chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) + + if (ktau<1000 .and. dbg_opt) then + ! if ( k==kts ) then + ! WRITE(6,*) 'add_emiss_burn: ktau,gmt,dtstep,time_int ',ktau,gmt,dtstep,time_int + ! WRITE(*,*) 'add_emiss_burn: i,j,xlat(i,j),xlong(i,j) ',i,j,xlat(i,j),xlong(i,j) + !WRITE(*,*) 'add_emiss_burn: luf_igbp(i,:,j) ',luf_igbp(i,:,j) + !WRITE(*,*) 'add_emiss_burn: lu_fire1(i,j) ',lu_fire1(i,j) + ! WRITE(6,*) 'add_emiss_burn: timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ',timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) + ! WRITE(*,*) 'add_emiss_burn: rainc(i,j),rainnc(i,j) ', rainc(i,j),rainnc(i,j) + ! endif + if ( k==kts .OR. k==kfire_max ) then + WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k + WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv ',rho_phy(i,k,j),dz8w(i,k,j),conv + WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke + endif + endif + + enddo + enddo + enddo + + ext2= sc_me + ab_me + do j=jts,jte + do k=kts,kte + do i=its,ite + + ! Check for NaNs, negative and too large numbers + IF (.NOT. (chem(i,k,j,p_smoke)>=0. .AND. chem(i,k,j,p_smoke)<1.1e+4)) THEN + chem(i,k,j,p_smoke)=1.e-16 + END IF + + aod3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) + aod3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) + enddo + enddo + enddo + + IF ( ktau<2000 .and. dbg_opt ) then + WRITE(*,*) 'add_emis_burn: i,j,k,ext2 ',i,j,k,ext2 + WRITE(*,*) 'add_emis_burn: rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) ',rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) ',aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) ',aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) + END IF + +! CASE DEFAULT +! call wrf_debug(15,'nothing done with burn emissions for chem array') +! END SELECT emiss_select + + END subroutine add_emis_burn + +END module module_add_emiss_burn diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 new file mode 100755 index 000000000..ea2c4e3f7 --- /dev/null +++ b/smoke/module_plumerise1.F90 @@ -0,0 +1,211 @@ + module module_plumerise1 + + use rrfs_smoke_data + use machine , only : kind_phys +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based +!------------------------------------------------------------------------- +! +! use module_zero_plumegen_coms +! integer, parameter :: nveg_agreg = 4 +! integer, parameter :: tropical_forest = 1 +! integer, parameter :: boreal_forest = 2 +! integer, parameter :: savannah = 3 + +! integer, parameter :: grassland = 4 +! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct +! character(len=20), parameter :: veg_name(nveg_agreg) = (/ & +! 'Tropical-Forest', & +! 'Boreal-Forest ', & +! 'Savanna ', & +! 'Grassland ' /) +! character(len=20), parameter :: spc_suf(nveg_agreg) = (/ & +! 'agtf' , & ! trop forest +! 'agef' , & ! extratrop forest +! 'agsv' , & ! savanna +! 'aggr' /) ! grassland + +CONTAINS +subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & + t_phy,q_vap, & ! RAR: moist is replaced with q_vap + rho_phy,vvel,u_phy,v_phy,p_phy, & + z_at_w,z,ktau, & ! scale_fire_emiss is part of config_flags + plume_frp, k_min, k_max, & ! RAR: + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + use rrfs_smoke_config + use physcons + use plume_data_mod + USE module_zero_plumegen_coms + USE module_smoke_plumerise + IMPLICIT NONE + type(smoke_data), intent(inout) :: data + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise + + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme, 2 ), INTENT(IN ) :: plume_frp ! RAR: FRP etc. array + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ktau, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte +! real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & +! INTENT(IN ) :: moist + real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu + + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac + +! real(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme ), & +! INTENT(IN ) :: ebu_in +! real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), & +! INTENT(IN ) :: & +! mean_fct_agtf,mean_fct_agef,& +! mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & +! firesize_agsv,firesize_aggr + + real(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: t_phy,z,z_at_w,vvel,u_phy,v_phy,rho_phy,p_phy,q_vap ! RAR + ! real(kind=kind_phys), INTENT(IN ) :: dtstep + +! Local variables... + INTEGER :: nv, i, j, k, kp1, kp2 + INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread + !real(kind_phys), dimension (num_ebu) :: eburn_in + !real(kind_phys), dimension (kte,num_ebu) :: eburn_out + real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev + real(kind=kind_phys) :: dz_plume + + !INTEGER, PARAMETER :: kfire_max=30 +! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct +! real(kind_phys) :: sum, ffirs, ratio +! real(kind_phys),save,dimension(its:ite,jts:jte) :: ffirs +! nspecies=num_ebu +! write(0,*)'plumerise' + +! RAR: +! if (config_flags%biomass_burn_opt == BIOMASSB_SMOKE) then +! do j=jts,jte: +! do i=its,ite +! ebu(i,kts,j,p_ebu_smoke)= ebb_smoke(i,j) +! ebu(i,kts,j,p_ebu_no) = ebu_in(i,1,j,p_ebu_in_no) +! ebu(i,kts,j,p_ebu_co) = ebu_in(i,1,j,p_ebu_in_co) +! ebu(i,kts,j,p_ebu_so2) = ebu_in(i,1,j,p_ebu_in_so2) +! ebu(i,kts,j,p_ebu_dms) = ebu_in(i,1,j,p_ebu_in_dms) +! ebu(i,kts,j,p_ebu_oc) = ebu_in(i,1,j,p_ebu_in_oc) +! ebu(i,kts,j,p_ebu_bc) = ebu_in(i,1,j,p_ebu_in_bc) +! ebu(i,kts,j,p_ebu_pm25) = ebu_in(i,1,j,p_ebu_in_pm25) +! ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10) +! enddo +! enddo + + IF ( dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte + WRITE(*,*) 'module_plumerise1: ims,ime,jms,jme ', ims,ime,jms,jme + !WRITE(*,*) 'module_plumerise1: p_ebu_smoke,num_ebu: ', p_ebu_smoke,num_ebu + WRITE(*,*) 'module_plumerise1: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) + END IF + !endif + +! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated + !do nv=1,num_ebu + do j=jts,jte + do k=kts+1,kte + do i=its,ite + ebu(i,k,j)=0. + enddo + enddo + enddo + !enddo + +! For now the flammable fraction is constant, based on the namelist. The next +! step to use LU index and meteorology to parameterize it +! IF (ktau==2) THEN + do j=jts,jte + do i=its,ite + flam_frac(i,j)= 0. + if (plume_frp(i,j,1) > frp_threshold) then + flam_frac(i,j)= 0.9 + end if + enddo + enddo + ! ENDIF + + +! RAR: new FRP based approach +!check_pl: IF (config_flags%plumerise_flag == 2 ) THEN ! if the namelist option is set for plumerise +! Haiqin: plumerise_flag is added to the namelist options +!check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise + do j=jts,jte + do i=its,ite + ! k_min(i,j)=0 + ! k_max(i,j)=0 + +! check_frp: if (.NOT.do_plumerise) then ! namelist option +! ebu(i,kts,j)= ebb_smoke(i,j) +! else + + do k=kts,kte + u_in(k)= u_phy(i,k,j) + v_in(k)= v_phy(i,k,j) + w_in(k)= vvel(i,k,j) + qv_in(k)= q_vap(i,k,j) ! RAR: moist(i,k,j,p_qv) + !pi_in(k)= cp*(p_phy(i,k,j)/p1000mb)**rcp + pi_in(k)= con_cp*(p_phy(i,k,j)/p1000mb)**con_rocp + zmid(k)= z(i,k,j)-z_at_w(i,kts,j) + z_lev(k)= z_at_w(i,k,j)-z_at_w(i,kts,j) + rho_phyin(k)= rho_phy(i,k,j) + theta_in(k)= t_phy(i,k,j)/pi_in(k)*con_cp + !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp + enddo + + IF (dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: i,j ',i,j + WRITE(*,*) 'module_plumerise1: plume_frp(i,j,:) ',plume_frp(i,j,:) + WRITE(*,*) 'module_plumerise1: ebu(i,kts,j) ',ebu(i,kts,j) + WRITE(*,*) 'module_plumerise1: u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) ',u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) + WRITE(*,*) 'module_plumerise1: zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) ',zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) + WRITE(*,*) 'module_plumerise1: t_phy(i,kte,j),pi_in(kte)',t_phy(i,kte,j),pi_in(kte) + END IF + +! RAR: the plume rise calculation step: + CALL plumerise(data,kte,1,1,1,1,1,1, & + !firesize,mean_fct, & + !num_ebu, eburn_in, eburn_out, & + u_in, v_in, w_in, theta_in ,pi_in, & + rho_phyin, qv_in, zmid, z_lev, & + plume_frp(i,j,1), k_min(i,j), & + k_max(i,j), ktau, dbg_opt ) + !k_max(i,j), ktau, config_flags%debug_chem ) + + kp1= k_min(i,j) + kp2= k_max(i,j) + dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) + + do k=kp1,kp2-1 + ebu(i,k,j)= flam_frac(i,j)* ebb_smoke(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume + enddo + ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) + + IF ( dbg_opt .and. ktau<2000) then + WRITE(*,*) 'module_plumerise1: i,j ',i,j + WRITE(*,*) 'module_plumerise1: k_min(i,j), k_max(i,j) ',k_min(i,j), k_max(i,j) + END IF +! endif check_frp + enddo + enddo + +! ENDIF check_pl + +end subroutine ebu_driver + +END module module_plumerise1 diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 new file mode 100755 index 000000000..f31759404 --- /dev/null +++ b/smoke/module_smoke_plumerise.F90 @@ -0,0 +1,2345 @@ +!------------------------------------------------------------------------- +!- 12 April 2016 +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based +!------------------------------------------------------------------------- +module module_smoke_plumerise + + use machine , only : kind_phys + use rrfs_smoke_data + use rrfs_smoke_config, only : FIRE_OPT_GBBEPx, FIRE_OPT_MODIS + use physcons, only : g => con_g, cp => con_cp, r_d => con_rd, r_v =>con_rv + use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & + !tropical_forest, boreal_forest, savannah, grassland, & + wind_eff + USE module_zero_plumegen_coms + + real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) + real(kind=kind_phys),parameter :: rgas=r_d + real(kind=kind_phys),parameter :: cpor=cp/r_d + real(kind=kind_phys),parameter :: p00=p1000mb +CONTAINS + +! RAR: + subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & +! firesize,mean_fct, & + ! nspecies,eburn_in,eburn_out, & + up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & + frp_inst,k1,k2, ktau, dbg_opt ) + + implicit none + type(smoke_data), intent(inout) :: data + + LOGICAL, INTENT (IN) :: dbg_opt + +! INTEGER, PARAMETER :: ihr_frp=1, istd_frp=2!, imean_fsize=3, istd_fsize=4 ! RAR: + +! integer, intent(in) :: PLUMERISE_flag + real(kind=kind_phys) :: frp_inst ! This is the instantenous FRP, at a given time step + + integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies + + INTEGER, INTENT (IN) :: ktau + INTEGER, INTENT (OUT) :: k1,k2 + +! integer :: ncall = 0 + integer :: kmt +! real(kind=kind_phys),dimension(m1,nspecies), intent(inout) :: eburn_out +! real(kind=kind_phys),dimension(nspecies), intent(in) :: eburn_in + + real(kind=kind_phys), dimension(m1,m2,m3) :: up, vp, wp,theta,pp,dn0,rv + real(kind=kind_phys), dimension(m1) :: zt_rams,zm_rams + real(kind=kind_phys) :: burnt_area,dzi,FRP ! RAR: + real(kind=kind_phys), dimension(2) :: ztopmax + real(kind=kind_phys) :: q_smold_kgm2 + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise + +! From plumerise1.F routine + integer, parameter :: iveg_ag=1 +! integer, parameter :: tropical_forest = 1 +! integer, parameter :: boreal_forest = 2 +! integer, parameter :: savannah = 3 +! integer, parameter :: grassland = 4 +! real(kind=kind_phys), dimension(nveg_agreg) :: firesize,mean_fct + + INTEGER, PARAMETER :: wind_eff = 1 + + type(plumegen_coms), pointer :: coms + +! integer:: iloop + !REAL(kind=kind_phys), INTENT (IN) :: convert_smold_to_flam + + !Fator de conversao de unidades + !!fcu=1. !=> kg [gas/part] /kg [ar] + !!fcu =1.e+12 !=> ng [gas/part] /kg [ar] + !!real(kind=kind_phys),parameter :: fcu =1.e+6 !=> mg [gas/part] /kg [ar] + !---------------------------------------------------------------------- + ! indexacao para o array "plume(k,i,j)" + ! k + ! 1 => area media (m^2) dos focos em biomas floresta dentro do gribox i,j + ! 2 => area media (m^2) dos focos em biomas savana dentro do gribox i,j + ! 3 => area media (m^2) dos focos em biomas pastagem dentro do gribox i,j + ! 4 => desvio padrao da area media (m^2) dos focos : floresta + ! 5 => desvio padrao da area media (m^2) dos focos : savana + ! 6 => desvio padrao da area media (m^2) dos focos : pastagem + ! 7 a 9 => sem uso + !10(=k_CO_smold) => parte da emissao total de CO correspondente a fase smoldering + !11, 12 e 13 => este array guarda a relacao entre + ! qCO( flaming, floresta) e a quantidade total emitida + ! na fase smoldering, isto e; + ! qCO( flaming, floresta) = plume(11,i,j)*plume(10,i,j) + ! qCO( flaming, savana ) = plume(12,i,j)*plume(10,i,j) + ! qCO( flaming, pastagem) = plume(13,i,j)*plume(10,i,j) + !20(=k_PM25_smold),21,22 e 23 o mesmo para PM25 + ! + !24-n1 => sem uso + !---------------------------------------------------------------------- +! print *,' Plumerise_scalar 1',ncall + coms => get_thread_coms() + if (ktau==2) then + call coms%set_to_zero() + endif + +IF (frp_inst there is not emission with + !- plume rise => cycle + + do k = 1,m1 ! loop over vertical grid + coms%ucon (k)=up(k,i,j) ! u wind + coms%vcon (k)=vp(k,i,j) ! v wind + !coms%wcon (k)=wp(k,i,j) ! w wind + coms%thtcon(k)=theta(k,i,j) ! pot temperature + coms%picon (k)=pp(k,i,j) ! exner function + !coms%tmpcon(k)=coms%thtcon(k)*coms%picon(k)/cp ! temperature (K) + !coms%dncon (k)=dn0(k,i,j) ! dry air density (basic state) + !coms%prcon (k)=(coms%picon(k)/cp)**cpor*p00 ! pressure (Pa) + coms%rvcon (k)=rv(k,i,j) ! water vapor mixing ratio + coms%zcon (k)=zt_rams(k) ! termod-point height + coms%zzcon (k)=zm_rams(k) ! W-point height + enddo + +! do ispc=2,nspecies + ! eburn_out(1,ispc) = eburn_in(ispc) ! eburn_in is the emissions at the 1st level +! eburn_out(2:m1,ispc)= 0. ! RAR: k>1 are used from eburn_out +! enddo + + !- get envinronmental state (temp, water vapor mix ratio, ...) + call get_env_condition(coms,1,m1,kmt,wind_eff,ktau) + + !- loop over the four types of aggregate biomes with fires for plumerise version 1 + !- for plumerise version 2, there is exist only one loop + ! iloop=1 +! IF (PLUMERISE_flag == 1) iloop=nveg_agreg + + !lp_veg: do iveg_ag=1,iloop + FRP = max(1000.,frp_inst) + + !- loop over the minimum and maximum heat fluxes/FRP + lp_minmax: do imm=1,2 + if(imm==1 ) then + burnt_area = 0.7* 0.00021* FRP ! - 0.5*plume_fre(istd_fsize)) + elseif(imm==2 ) then + burnt_area = 1.3* 0.00021* FRP + endif + burnt_area= max(1.0e4,burnt_area) + + IF (dbg_opt .AND. ktau<2000) THEN + WRITE(*,*) 'plumerise: m1,ktau ', m1,ktau + WRITE(*,*) 'plumerise: imm, FRP,burnt_area ', imm, FRP,burnt_area + ! WRITE(*,*) 'convert_smold_to_flam ',convert_smold_to_flam + WRITE(*,*) 'plumerise: zcon ', coms%zcon + WRITE(*,*) 'plumerise: zzcon ', coms%zzcon + END IF + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise: imm ', imm + WRITE(*,*) 'plumerise: burnt_area ',burnt_area + END IF + + !- get fire properties (burned area, plume radius, heating rates ...) + call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) + + !------ generates the plume rise ------ + call makeplume (coms,kmt,ztopmax(imm),ixx,imm) + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise after makeplume: imm,kmt,ztopmax(imm) ',imm,kmt,ztopmax(imm) + END IF + + enddo lp_minmax + + !- define o dominio vertical onde a emissao flaming ira ser colocada + call set_flam_vert(ztopmax,k1,k2,nkp,coms%zzcon) !,W_VMD,VMD) + + ! IF (ktau<2000) then + ! WRITE(6,*) 'module_chem_plumerise_scalar: eburn_out(:,3) ', eburn_out(:,3) + ! END IF + + !- thickness of the vertical layer between k1 and k2 eta levels (lower and upper bounds for the injection height ) + !dzi= 1./(coms%zzcon(k2)-coms%zzcon(k1)) ! RAR: k2>=k1+1 + + !- emission during flaming phase is evenly distributed between levels k1 and k2 + !do k=k1,k2 + ! do ispc= 2,nspecies + ! eburn_out(k,ispc)= dzi* eburn_in(ispc) + ! enddo + !enddo + + IF (dbg_opt .AND. ktau<2000) then + WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 + WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi + !WRITE(*,*) 'plumerise after set_flam_vert: eburn_in(2) ', eburn_in(2) + !WRITE(*,*) 'plumerise after set_flam_vert: eburn_out(:,2) ',eburn_out(:,2) + END IF + +! enddo lp_veg ! sub-grid vegetation, currently it's aggregated + +end subroutine plumerise +!------------------------------------------------------------------------- + +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) + +!se module_zero_plumegen_coms +!use rconstants +implicit none +type(plumegen_coms), pointer :: coms +integer :: k1,k2,k,kcon,klcl,kmt,nk,nkmid,i +real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy +!integer :: n_setgrid = 0 +integer :: wind_eff,ktau + +if(ktau==2) then + ! n_setgrid = 1 + call set_grid(coms) ! define vertical grid of plume model + ! coms%zt(k) = thermo and water levels + ! coms%zm(k) = dynamical levels +endif + +znz=coms%zcon(k2) +do k=nkp,1,-1 + if(coms%zt(k).lt.znz)go to 13 +enddo +stop ' envir stop 12' +13 continue +!-srf-mb +kmt=min(k,nkp-1) + +nk=k2-k1+1 +!call htint(nk, coms%wcon,coms%zzcon,kmt,wpe,coms%zt) + call htint(nk, coms%ucon,coms%zcon,kmt,coms%upe,coms%zt) + call htint(nk, coms%vcon,coms%zcon,kmt,coms%vpe,coms%zt) + call htint(nk,coms%thtcon,coms%zcon,kmt,coms%the ,coms%zt) + call htint(nk, coms%rvcon,coms%zcon,kmt,coms%qvenv,coms%zt) +do k=1,kmt + coms%qvenv(k)=max(coms%qvenv(k),1e-8) +enddo + +coms%pke(1)=coms%picon(1) +do k=1,kmt + coms%thve(k)=coms%the(k)*(1.+.61*coms%qvenv(k)) ! virtual pot temperature +enddo +do k=2,kmt + coms%pke(k)=coms%pke(k-1)-g*2.*(coms%zt(k)-coms%zt(k-1)) & ! exner function + /(coms%thve(k)+coms%thve(k-1)) +enddo +do k=1,kmt + coms%te(k) = coms%the(k)*coms%pke(k)/cp ! temperature (K) + coms%pe(k) = (coms%pke(k)/cp)**cpor*p00 ! pressure (Pa) + coms%dne(k)= coms%pe(k)/(rgas*coms%te(k)*(1.+.61*coms%qvenv(k))) ! dry air density (kg/m3) +! print*,'ENV=',coms%qvenv(k)*1000., coms%te(k)-273.15,coms%zt(k) +!-srf-mb + coms%vel_e(k) = sqrt(coms%upe(k)**2+coms%vpe(k)**2) !-env wind (m/s) + !print*,'k,coms%vel_e(k),coms%te(k)=',coms%vel_e(k),coms%te(k) +enddo + +!-ewe - env wind effect +if(wind_eff < 1) coms%vel_e(1:kmt) = 0. + +!-use este para gerar o RAMS.out +! ------- print environment state +!print*,'k,coms%zt(k),coms%pe(k),coms%te(k)-273.15,coms%qvenv(k)*1000' +!do k=1,kmt +! write(*,100) k,coms%zt(k),coms%pe(k),coms%te(k)-273.15,coms%qvenv(k)*1000. +! 100 format(1x,I5,4f20.12) +!enddo +!stop 333 + + +!--------- nao eh necessario este calculo +!do k=1,kmt +! call thetae(coms%pe(k),coms%te(k),coms%qvenv(k),coms%thee(k)) +!enddo + + +!--------- converte press de Pa para kPa para uso modelo de plumerise +do k=1,kmt + coms%pe(k) = coms%pe(k)*1.e-3 +enddo + +return +end subroutine get_env_condition + +!------------------------------------------------------------------------- + +subroutine set_grid(coms) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: k,mzp + +coms%dz=100. ! set constant grid spacing of plume grid model(meters) + +mzp=nkp +coms%zt(1) = coms%zsurf +coms%zm(1) = coms%zsurf +coms%zt(2) = coms%zt(1) + 0.5*coms%dz +coms%zm(2) = coms%zm(1) + coms%dz +do k=3,mzp + coms%zt(k) = coms%zt(k-1) + coms%dz ! thermo and water levels + coms%zm(k) = coms%zm(k-1) + coms%dz ! dynamical levels +enddo +!print*,coms%zsurf +!Print*,coms%zt(:) +do k = 1,mzp-1 + coms%dzm(k) = 1. / (coms%zt(k+1) - coms%zt(k)) +enddo +coms%dzm(mzp)=coms%dzm(mzp-1) + +do k = 2,mzp + coms%dzt(k) = 1. / (coms%zm(k) - coms%zm(k-1)) +enddo +coms%dzt(1) = coms%dzt(2) * coms%dzt(2) / coms%dzt(3) + +! coms%dzm(1) = 0.5/coms%dz +! coms%dzm(2:mzp) = 1./coms%dz +return +end subroutine set_grid +!------------------------------------------------------------------------- + + SUBROUTINE set_flam_vert(ztopmax,k1,k2,nkp,zzcon) !,W_VMD,VMD) + + REAL(kind=kind_phys) , INTENT(IN) :: ztopmax(2) + INTEGER , INTENT(OUT) :: k1,k2 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL(kind=kind_phys) , INTENT(IN) :: zzcon(nkp) + + INTEGER imm,k + INTEGER, DIMENSION(2) :: k_lim + + !- version 2 +! REAL(kind=kind_phys) , INTENT(IN) :: W_VMD(nkp,2) +! REAL(kind=kind_phys) , INTENT(OUT) :: VMD(nkp,2) +! real(kind=kind_phys) w_thresold,xxx +! integer k_initial,k_final,ko,kk4,kl + + !- version 1 + DO imm=1,2 + ! checar + ! do k=1,m1-1 + DO k=1,nkp-1 + IF(zzcon(k) > ztopmax(imm)) EXIT + ENDDO + k_lim(imm) = k + ENDDO + k1= MIN(MAX(4,k_lim(1)),51) + k2= MIN(51,k_lim(2)) ! RAR: the model doesn't simulate very high injection heights, so it's safe to assume maximum heigh of 12km AGL for HRRR grid + + IF (k2 <= k1) THEN + !print*,'1: ztopmax k=',ztopmax(1), k1 + !print*,'2: ztopmax k=',ztopmax(2), k2 + k2= k1+1 ! RAR: I added k1+1 + ENDIF + + !- version 2 + !- vertical mass distribution + !- +! w_thresold = 1. +! DO imm=1,2 + +! VMD(1:nkp,imm)= 0. +! xxx=0. +! k_initial= 0 +! k_final = 0 + + !- define range of the upper detrainemnt layer +! do ko=nkp-10,2,-1 + +! if(w_vmd(ko,imm) < w_thresold) cycle + +! if(k_final==0) k_final=ko + +! if(w_vmd(ko,imm)-1. > w_vmd(ko-1,imm)) then +! k_initial=ko +! exit +! endif + +! enddo + !- if there is a non zero depth layer, make the mass vertical distribution +! if(k_final > 0 .and. k_initial > 0) then + +! k_initial=int((k_final+k_initial)*0.5) + + !- parabolic vertical distribution between k_initial and k_final +! kk4 = k_final-k_initial+2 +! do ko=1,kk4-1 +! kl=ko+k_initial-1 +! VMD(kl,imm) = 6.* float(ko)/float(kk4)**2 * (1. - float(ko)/float(kk4)) +! enddo +! if(sum(VMD(1:NKP,imm)) .ne. 1.) then +! xxx= ( 1.- sum(VMD(1:NKP,imm)) )/float(k_final-k_initial+1) +! do ko=k_initial,k_final +! VMD(ko,imm) = VMD(ko,imm)+ xxx !- values between 0 and 1. +! enddo + ! print*,'new mass=',sum(mass)*100.,xxx + !pause +! endif +! endif !k_final > 0 .and. k_initial > + +! ENDDO + + END SUBROUTINE set_flam_vert +!------------------------------------------------------------------------- + +subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: moist, i, icount,imm,iveg_ag !,plumerise_flag +real(kind=kind_phys):: bfract, effload, heat, hinc ,burnt_area,heat_fluxW,FRP +real(kind=kind_phys), dimension(2,4) :: heat_flux +INTEGER, parameter :: use_last = 0 +!real(kind=kind_phys), parameter :: beta = 5.0 !ref.: Wooster et al., 2005 +REAL(kind=kind_phys), parameter :: beta = 0.88 !ref.: Paugam et al., 2015 + +data heat_flux/ & +!--------------------------------------------------------------------- +! heat flux !IGBP Land Cover ! +! min ! max !Legend and ! reference +! kW/m^2 !description ! +!-------------------------------------------------------------------- +30.0, 80.0, &! Tropical Forest ! igbp 2 & 4 +30.0, 80.0, &! Boreal(kind=kind_phys) forest ! igbp 1 & 3 +4.4, 23.0, &! cerrado/woody savanna | igbp 5 thru 9 +3.3, 3.3 /! Grassland/cropland ! igbp 10 thru 17 +!-------------------------------------------------------------------- +!-- fire at surface +! +!coms%area = 20.e+4 ! area of burn, m^2 +coms%area = burnt_area! area of burn, m^2 + +!IF ( PLUMERISE_flag == 1) THEN +! !fluxo de calor para o bioma +! heat_fluxW = heat_flux(imm,iveg_ag) * 1000. ! converte para W/m^2 + +!ELSEIF ( PLUMERISE_flag == 2) THEN + ! "beta" factor converts FRP to convective energy + heat_fluxW = beta*(FRP/coms%area)/0.55 ! in W/m^2 +! FIXME: These five lines were not in the known-working version. Delete them? +! if(coms%area<1e-6) then +! heat_fluxW = 0 +! else +! heat_fluxW = beta*(FRP/coms%area)/0.55 ! in W/m^2 +! endif + +!ENDIF + +coms%mdur = 53 ! duration of burn, minutes +coms%bload = 10. ! total loading, kg/m**2 +moist = 10 ! fuel moisture, %. average fuel moisture,percent dry +coms%maxtime =coms%mdur+2 ! model time, min +!heat = 21.e6 !- joules per kg of fuel consumed +!heat = 15.5e6 !joules/kg - cerrado +heat = 19.3e6 !joules/kg - floresta em alta floresta (mt) +!coms%alpha = 0.1 !- entrainment constant +coms%alpha = 0.05 !- entrainment constant + +!-------------------- printout ---------------------------------------- + +!!WRITE ( * , * ) ' SURFACE =', COMS%ZSURF, 'M', ' LCL =', COMS%ZBASE, 'M' +! +!PRINT*,'=======================================================' +!print * , ' FIRE BOUNDARY CONDITION :' +!print * , ' DURATION OF BURN, MINUTES =',COMS%MDUR +!print * , ' AREA OF BURN, HA =',COMS%AREA*1.e-4 +!print * , ' HEAT FLUX, kW/m^2 =',heat_fluxW*1.e-3 +!print * , ' TOTAL LOADING, KG/M**2 =',COMS%BLOAD +!print * , ' FUEL MOISTURE, % =',MOIST !average fuel moisture,percent dry +!print * , ' MODEL TIME, MIN. =',COMS%MAXTIME +! +! +! +! ******************** fix up inputs ********************************* +! + +!IF (MOD (COMS%MAXTIME, 2) .NE.0) COMS%MAXTIME = COMS%MAXTIME+1 !make coms%maxtime even + +COMS%MAXTIME = COMS%MAXTIME * 60 ! and put in seconds +! +COMS%RSURF = SQRT (COMS%AREA / 3.14159) !- entrainment surface radius (m) + +COMS%FMOIST = MOIST / 100. !- fuel moisture fraction +! +! +! calculate the energy flux and water content at lboundary. +! fills heating() on a minute basis. could ask for a file at this po +! in the program. whatever is input has to be adjusted to a one +! minute timescale. +! + + DO I = 1, ntime !- make sure of energy release + COMS%HEATING (I) = 0.0001 !- avoid possible divide by 0 + enddo +! + COMS%TDUR = COMS%MDUR * 60. !- number of seconds in the burn + + bfract = 1. !- combustion factor + + EFFLOAD = COMS%BLOAD * BFRACT !- patchy burning + +! spread the burning evenly over the interval +! except for the first few minutes for stability + ICOUNT = 1 +! + if(COMS%MDUR > NTIME) STOP 'Increase time duration (ntime) in min - see file "module_zero_plumegen_coms.F90"' + + DO WHILE (ICOUNT.LE.COMS%MDUR) +! COMS%HEATING (ICOUNT) = HEAT * EFFLOAD / COMS%TDUR ! W/m**2 +! COMS%HEATING (ICOUNT) = 80000. * 0.55 ! W/m**2 + + COMS%HEATING (ICOUNT) = heat_fluxW * 0.55 ! W/m**2 (0.55 converte para energia convectiva) + ICOUNT = ICOUNT + 1 + ENDDO +! ramp for 5 minutes + IF(use_last /= 1) THEN + + HINC = COMS%HEATING (1) / 4. + COMS%HEATING (1) = 0.1 + COMS%HEATING (2) = HINC + COMS%HEATING (3) = 2. * HINC + COMS%HEATING (4) = 3. * HINC + ELSE + IF(imm==1) THEN + HINC = COMS%HEATING (1) / 4. + COMS%HEATING (1) = 0.1 + COMS%HEATING (2) = HINC + COMS%HEATING (3) = 2. * HINC + COMS%HEATING (4) = 3. * HINC + ELSE + HINC = (COMS%HEATING (1) - heat_flux(imm-1,iveg_ag) * 1000. *0.55)/ 4. + COMS%HEATING (1) = heat_flux(imm-1,iveg_ag) * 1000. *0.55 + 0.1 + COMS%HEATING (2) = COMS%HEATING (1)+ HINC + COMS%HEATING (3) = COMS%HEATING (2)+ HINC + COMS%HEATING (4) = COMS%HEATING (3)+ HINC + ENDIF + ENDIF + +return +end subroutine get_fire_properties +!------------------------------------------------------------------------------- +! +SUBROUTINE MAKEPLUME (coms,kmt,ztopmax,ixx,imm) +! +! ********************************************************************* +! +! EQUATION SOURCE--Kessler Met.Monograph No. 32 V.10 (K) +! Alan Weinstein, JAS V.27 pp 246-255. (W), +! Ogura and Takahashi, Monthly Weather Review V.99,pp895-911 (OT) +! Roger Pielke,Mesoscale Meteorological Modeling,Academic Press,1984 +! Originally developed by: Don Latham (USFS) +! +! +! ************************ VARIABLE ID ******************************** +! +! DT=COMPUTING TIME INCREMENT (SEC) +! DZ=VERTICAL INCREMENT (M) +! LBASE=LEVEL ,CLOUD BASE +! +! CONSTANTS: +! G = GRAVITATIONAL ACCELERATION 9.80796 (M/SEC/SEC). +! R = DRY AIR GAS CONSTANT (287.04E6 JOULE/KG/DEG K) +! CP = SPECIFIC HT. (1004 JOULE/KG/DEG K) +! HEATCOND = HEAT OF CONDENSATION (2.5E6 JOULE/KG) +! HEATFUS = HEAT OF FUSION (3.336E5 JOULE/KG) +! HEATSUBL = HEAT OF SUBLIMATION (2.83396E6 JOULE/KG) +! EPS = RATIO OF MOL.WT. OF WATER VAPOR TO THAT OF DRY AIR (0.622) +! DES = DIFFERENCE BETWEEN VAPOR PRESSURE OVER WATER AND ICE (MB) +! TFREEZE = FREEZING TEMPERATURE (K) +! +! +! PARCEL VALUES: +! T = TEMPERATURE (K) +! TXS = TEMPERATURE EXCESS (K) +! QH = HYDROMETEOR WATER CONTENT (G/G DRY AIR) +! QHI = HYDROMETEOR ICE CONTENT (G/G DRY AIR) +! QC = WATER CONTENT (G/G DRY AIR) +! QVAP = WATER VAPOR MIXING RATIO (G/G DRY AIR) +! QSAT = SATURATION MIXING RATIO (G/G DRY AIR) +! RHO = DRY AIR DENSITY (G/M**3) MASSES = RHO*Q'S IN G/M**3 +! ES = SATURATION VAPOR PRESSURE (kPa) +! +! ENVIRONMENT VALUES: +! TE = TEMPERATURE (K) +! PE = PRESSURE (kPa) +! QVENV = WATER VAPOR (G/G) +! RHE = RELATIVE HUMIDITY FRACTION (e/esat) +! DNE = dry air density (kg/m^3) +! +! HEAT VALUES: +! HEATING = HEAT OUTPUT OF FIRE (WATTS/M**2) +! MDUR = DURATION OF BURN, MINUTES +! +! W = VERTICAL VELOCITY (M/S) +! RADIUS=ENTRAINMENT RADIUS (FCN OF Z) +! RSURF = ENTRAINMENT RADIUS AT GROUND (SIMPLE PLUME, TURNER) +! ALPHA = ENTRAINMENT CONSTANT +! MAXTIME = TERMINATION TIME (MIN) +! +! +!********************************************************************** +!********************************************************************** +!use module_zero_plumegen_coms +implicit none +!logical :: endspace +type(plumegen_coms), pointer :: coms +character (len=10) :: varn +integer :: izprint, iconv, itime, k, kk, kkmax, deltak,ilastprint,kmt & + ,ixx,nrectotal,i_micro,n_sub_step +real(kind=kind_phys) :: vc, g, r, cp, eps, & + tmelt, heatsubl, heatfus, heatcond, tfreeze, & + ztopmax, wmax, rmaxtime, es, esat, heat,dt_save !ESAT_PR, +character (len=2) :: cixx +! Set threshold to be the same as dz=100., the constant grid spacing of plume grid model(meters) found in set_grid() + REAL(kind=kind_phys) :: DELZ_THRESOLD = 100. + + INTEGER :: imm + +! real(kind=kind_phys), external:: esat_pr! +! +! ******************* SOME CONSTANTS ********************************** +! +! XNO=10.0E06 median volume diameter raindrop (K table 4) +! VC = 38.3/(XNO**.125) mean volume fallspeed eqn. (K) +! +parameter (vc = 5.107387) +parameter (g = 9.80796, r = 287.04, cp = 1004., eps = 0.622, tmelt = 273.3) +parameter (heatsubl = 2.834e6, heatfus = 3.34e5, heatcond = 2.501e6) +parameter (tfreeze = 269.3) +! +coms%tstpf = 2.0 !- timestep factor +coms%viscosity = 500.!- coms%viscosity constant (original value: 0.001) + +nrectotal=150 +! +!*************** PROBLEM SETUP AND INITIAL CONDITIONS ***************** +coms%mintime = 1 +ztopmax = 0. +coms%ztop = 0. + coms%time = 0. + coms%dt = 1. + wmax = 1. +kkmax = 10 +deltaK = 20 +ilastprint=0 +COMS%L = 1 ! COMS%L initialization + +!--- initialization +CALL INITIAL(coms,kmt) + +!--- initial print fields: +izprint = 0 ! if = 0 => no printout +!if (izprint.ne.0) then +! write(cixx(1:2),'(i2.2)') ixx +! open(2, file = 'debug.'//cixx//'.dat') +! open(19,file='plumegen9.'//cixx//'.gra', & +! form='unformatted',access='direct',status='unknown', & +! recl=4*nrectotal) !PC +! recl=1*nrectotal) !sx6 e tupay +! call printout (izprint,nrectotal) +! ilastprint=2 +!endif + +! ******************* model evolution ****************************** +rmaxtime = float(coms%maxtime) +! +!print * ,' TIME=',coms%time,' RMAXTIME=',rmaxtime +!print*,'=======================================================' + DO WHILE (COMS%TIME.LE.RMAXTIME) !beginning of time loop + +! do itime=1,120 + +!-- set model top integration + coms%nm1 = min(kmt, kkmax + deltak) +!sam 81 format('nm1=',I0,' from kmt=',I0,' kkmax=',I0,' deltak=',I0) +!sam write(0,81) coms%nm1,kmt,kkmax,deltak +!-- set timestep + !coms%dt = (coms%zm(2)-coms%zm(1)) / (coms%tstpf * wmax) + coms%dt = min(5.,(coms%zm(2)-coms%zm(1)) / (coms%tstpf * wmax)) + +!-- elapsed time, sec + coms%time = coms%time+coms%dt +!-- elapsed time, minutes + coms%mintime = 1 + int (coms%time) / 60 + wmax = 1. !no zeroes allowed. +!************************** BEGIN SPACE LOOP ************************** + +!-- zerout all model tendencies + call tend0_plumerise(coms) + +!-- bounday conditions (k=1) + COMS%L=1 + call lbound(coms) + +!-- dynamics for the level k>1 +!-- W advection +! call vel_advectc_plumerise(COMS%NM1,COMS%WC,COMS%WT,COMS%DNE,COMS%DZM) + call vel_advectc_plumerise(COMS%NM1,COMS%WC,COMS%WT,COMS%RHO,COMS%DZM) + +!-- scalars advection 1 + call scl_advectc_plumerise(coms,'SC',COMS%NM1) + +!-- scalars advection 2 + !call scl_advectc_plumerise2(coms,'SC',COMS%NM1) + +!-- scalars entrainment, adiabatic + call scl_misc(coms,COMS%NM1) + +!-- scalars dinamic entrainment + call scl_dyn_entrain(COMS%NM1,nkp,coms%wbar,coms%w,coms%adiabat,coms%alpha,coms%radius,coms%tt,coms%t,coms%te,coms%qvt,coms%qv,coms%qvenv,coms%qct,coms%qc,coms%qht,coms%qh,coms%qit,coms%qi,& + coms%vel_e,coms%vel_p,coms%vel_t,coms%rad_p,coms%rad_t) + +!-- gravity wave damping using Rayleigh friction layer fot COMS%T + call damp_grav_wave(1,coms%nm1,deltak,coms%dt,coms%zt,coms%zm,coms%w,coms%t,coms%tt,coms%qv,coms%qh,coms%qi,coms%qc,coms%te,coms%pe,coms%qvenv) + +!-- microphysics +! goto 101 ! bypass microphysics + dt_save=coms%dt + n_sub_step=3 + coms%dt=coms%dt/float(n_sub_step) + + do i_micro=1,n_sub_step +!-- sedim ? + call fallpart(coms,COMS%NM1) +!-- microphysics + coms%L=2 + do while(coms%L<=coms%nm1-1) + !do L=2,coms%nm1-1 + COMS%WBAR = 0.5*(coms%W(COMS%L)+coms%W(COMS%L-1)) + ES = ESAT_PR (COMS%T(COMS%L)) !BLOB SATURATION VAPOR PRESSURE, EM KPA + COMS%QSAT(COMS%L) = (EPS * ES) / (COMS%PE(COMS%L) - ES) !BLOB SATURATION LWC G/G DRY AIR + COMS%EST (COMS%L) = ES +!sam if(.not.coms%pe(coms%L)>0 .or. .not. coms%T(coms%L)>200) then +!sam 1304 format('(1304) bad input to rho at L=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1304) coms%L,coms%PE(coms%L),coms%T(coms%L) +!sam endif + COMS%RHO (COMS%L) = 3483.8 * COMS%PE (COMS%L) / COMS%T (COMS%L) ! AIR PARCEL DENSITY , G/M**3 +!srf18jun2005 +! IF (COMS%W(COMS%L) .ge. 0.) COMS%DQSDZ = (COMS%QSAT(COMS%L ) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L ) -COMS%ZT(COMS%L-1)) +! IF (COMS%W(COMS%L) .lt. 0.) COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L )) / (COMS%ZT(COMS%L+1) -COMS%ZT(COMS%L )) + IF (COMS%W(COMS%L) .ge. 0.) then + COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L+1 )-COMS%ZT(COMS%L-1)) + ELSE + COMS%DQSDZ = (COMS%QSAT(COMS%L+1) - COMS%QSAT(COMS%L-1)) / (COMS%ZT(COMS%L+1) -COMS%ZT(COMS%L-1)) + ENDIF + + call waterbal(coms) + coms%L=coms%L+1 + enddo + enddo + coms%dt=dt_save +! + 101 continue +! +!-- W-viscosity for stability + call visc_W(coms,coms%nm1,deltak,kmt) + +!-- update scalars + call update_plumerise(coms,coms%nm1,'S') + + call hadvance_plumerise(1,coms%nm1,coms%dt,COMS%WC,COMS%WT,COMS%W,coms%mintime) + +!-- Buoyancy + call buoyancy_plumerise(COMS%NM1, COMS%T, COMS%TE, COMS%QV, COMS%QVENV, COMS%QH, COMS%QI, COMS%QC, COMS%WT, COMS%SCR1) + +!-- Entrainment + call entrainment(coms,COMS%NM1,COMS%W,COMS%WT,COMS%RADIUS,COMS%ALPHA) + +!-- update W + call update_plumerise(coms,coms%nm1,'W') + + call hadvance_plumerise(2,coms%nm1,coms%dt,COMS%WC,COMS%WT,COMS%W,coms%mintime) + + +!-- misc + do k=2,coms%nm1 +! coms%pe esta em kpa - esat do rams esta em mbar = 100 Pa = 0.1 kpa +! es = 0.1*esat (coms%t(k)) !blob saturation vapor pressure, em kPa +! rotina do plumegen calcula em kPa + es = esat_pr (coms%t(k)) !blob saturation vapor pressure, em kPa + coms%qsat(k) = (eps * es) / (coms%pe(k) - es) !blob saturation lwc g/g dry air + coms%est (k) = es + coms%txs (k) = coms%t(k) - coms%te(k) +!sam if(.not.coms%pe(K)>0 .or. .not. coms%T(K)>200) then +!sam 1305 format('(1305) bad input to rho at K=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1305) K,coms%PE(K),coms%T(K) +!sam endif + coms%rho (k) = 3483.8 * coms%pe (k) / coms%t (k) ! air parcel density , g/m**3 + ! no pressure diff with radius + if((abs(coms%wc(k))).gt.wmax) wmax = abs(coms%wc(k)) ! keep wmax largest w + enddo + +! Gravity wave damping using Rayleigh friction layer for W + call damp_grav_wave(2,coms%nm1,deltak,coms%dt,coms%zt,coms%zm,coms%w,coms%t,coms%tt,coms%qv,coms%qh,coms%qi,coms%qc,coms%te,coms%pe,coms%qvenv) +!--- + !- update radius + do k=2,coms%nm1 + coms%radius(k) = coms%rad_p(k) + enddo + !-- try to find the plume top (above surface height) + kk = 1 + DO WHILE (coms%w (kk) .GT. 1.) + kk = kk + 1 + coms%ztop = coms%zm(kk) + !print*,'W=',coms%w (kk) + ENDDO + ! + coms%ztop_(coms%mintime) = coms%ztop + ztopmax = MAX (coms%ztop, ztopmax) + kkmax = MAX (kk , kkmax ) + !print * ,'ztopmax=', coms%mintime,'mn ',coms%ztop_(coms%mintime), ztopmax + + ! + ! if the solution is going to a stationary phase, exit + IF(coms%mintime > 10) THEN + ! if(coms%mintime > 20) then + ! if( abs(coms%ztop_(coms%mintime)-coms%ztop_(coms%mintime-10)) < COMS%DZ ) exit + IF( ABS(coms%ztop_(coms%mintime)-coms%ztop_(coms%mintime-10)) < DELZ_THRESOLD) then + !- determine W parameter to determine the VMD + !do k=2,coms%nm1 + ! W_VMD(k,imm) = coms%w(k) + !enddo + EXIT ! finish the integration + ENDIF + ENDIF + + ! if(ilastprint == coms%mintime) then + ! call printout (izprint,nrectotal) + ! ilastprint = coms%mintime+1 + ! endif + + +ENDDO !do next timestep + +!print * ,' ztopmax=',ztopmax,'m',coms%mintime,'mn ' +!print*,'=======================================================' +! +!the last printout +!if (izprint.ne.0) then +! call printout (izprint,nrectotal) +! close (2) +! close (19) +!endif + +RETURN +END SUBROUTINE MAKEPLUME +!------------------------------------------------------------------------------- +! +SUBROUTINE BURN(COMS, EFLUX, WATER) +! +!- calculates the energy flux and water content at lboundary +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +!real(kind=kind_phys), parameter :: HEAT = 21.E6 !Joules/kg +!real(kind=kind_phys), parameter :: HEAT = 15.5E6 !Joules/kg - cerrado +real(kind=kind_phys), parameter :: HEAT = 19.3E6 !Joules/kg - floresta em Alta Floresta (MT) +real(kind=kind_phys) :: eflux,water +! +! The emission factor for water is 0.5. The water produced, in kg, +! is then fuel mass*0.5 + (moist/100)*mass per square meter. +! The fire burns for DT out of TDUR seconds, the total amount of +! fuel burned is AREA*COMS%BLOAD*(COMS%DT/TDUR) kg. this amount of fuel is +! considered to be spread over area AREA and so the mass burned per +! unit area is COMS%BLOAD*(COMS%DT/TDUR), and the rate is COMS%BLOAD/TDUR. +! +IF (COMS%TIME.GT.COMS%TDUR) THEN !is the burn over? + EFLUX = 0.000001 !prevent a potential divide by zero + WATER = 0. + RETURN +ELSE +! + EFLUX = COMS%HEATING (COMS%MINTIME) ! Watts/m**2 +! WATER = EFLUX * (COMS%DT / HEAT) * (0.5 + COMS%FMOIST) ! kg/m**2 + WATER = EFLUX * (COMS%DT / HEAT) * (0.5 + COMS%FMOIST) /0.55 ! kg/m**2 + WATER = WATER * 1000. ! g/m**2 +! +! print*,'BURN:',coms%time,EFLUX/1.e+9 +ENDIF +! +RETURN +END SUBROUTINE BURN +!------------------------------------------------------------------------------- +! +SUBROUTINE LBOUND (coms) +! +! ********** BOUNDARY CONDITIONS AT ZSURF FOR PLUME AND CLOUD ******** +! +! source of equations: J.S. Turner Buoyancy Effects in Fluids +! Cambridge U.P. 1973 p.172, +! G.A. Briggs Plume Rise, USAtomic Energy Commissio +! TID-25075, 1969, P.28 +! +! fundamentally a point source below ground. at surface, this produces +! a velocity w(1) and temperature T(1) which vary with time. There is +! also a water load which will first saturate, then remainder go into +! QC(1). +! EFLUX = energy flux at ground,watt/m**2 for the last DT +! +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: g = 9.80796, r = 287.04, cp = 1004.6, eps = 0.622,tmelt = 273.3 +real(kind=kind_phys), parameter :: tfreeze = 269.3, pi = 3.14159, e1 = 1./3., e2 = 5./3. +real(kind=kind_phys) :: es, esat, eflux, water, pres, c1, c2, f, zv, denscor, xwater !,ESAT_PR +! real(kind=kind_phys), external:: esat_pr! + +! +COMS%QH (1) = COMS%QH (2) !soak up hydrometeors +COMS%QI (1) = COMS%QI (2) +COMS%QC (1) = 0. !no cloud here +! +! + CALL BURN (COMS, EFLUX, WATER) +! +! calculate parameters at boundary from a virtual buoyancy point source +! + PRES = COMS%PE (1) * 1000. !need pressure in N/m**2 + + C1 = 5. / (6. * COMS%ALPHA) !alpha is entrainment constant + + C2 = 0.9 * COMS%ALPHA + + F = EFLUX / (PRES * CP * PI) + + F = G * R * F * COMS%AREA !buoyancy flux + + ZV = C1 * COMS%RSURF !virtual boundary height + + COMS%W (1) = C1 * ( (C2 * F) **E1) / ZV**E1 !boundary velocity + + DENSCOR = C1 * F / G / (C2 * F) **E1 / ZV**E2 !density correction + + COMS%T (1) = COMS%TE (1) / (1. - DENSCOR) !temperature of virtual plume at zsurf + +! + COMS%WC(1) = COMS%W(1) + COMS%VEL_P(1) = 0. + coms%rad_p(1) = coms%rsurf + + !COMS%SC(1) = COMS%SCE(1)+F/1000.*coms%dt ! gas/particle (g/g) + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! match dw/dz,dt/dz at the boundary. F is conserved. +! + !COMS%WBAR = COMS%W (1) * (1. - 1. / (6. * ZV) ) + !COMS%ADVW = COMS%WBAR * COMS%W (1) / (3. * ZV) + !COMS%ADVT = COMS%WBAR * (5. / (3. * ZV) ) * (DENSCOR / (1. - DENSCOR) ) + !COMS%ADVC = 0. + !COMS%ADVH = 0. + !COMS%ADVI = 0. + !COMS%ADIABAT = - COMS%WBAR * G / CP + COMS%VTH (1) = - 4. + COMS%VTI (1) = - 3. + COMS%TXS (1) = COMS%T (1) - COMS%TE (1) + + COMS%VISC (1) = COMS%VISCOSITY + +!sam if(.not.coms%pe(1)>0 .or. .not. coms%T(1)>200) then +!sam 1306 format('(1306) bad input to rho at 1=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1306) 1,coms%PE(1),coms%T(1) +!sam endif + COMS%RHO (1) = 3483.8 * COMS%PE (1) / COMS%T (1) !air density at level 1, g/m**3 + + XWATER = WATER / max(1e-20, COMS%W (1) * COMS%DT * COMS%RHO (1) ) !firewater mixing ratio + + COMS%QV (1) = XWATER + COMS%QVENV (1) !plus what's already there + + +! COMS%PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa +! ES = 0.1*ESAT (COMS%T(1)) !blob saturation vapor pressure, em kPa +! rotina do plumegen ja calcula em kPa + ES = ESAT_PR (COMS%T(1)) !blob saturation vapor pressure, em kPa + + COMS%EST (1) = ES + COMS%QSAT (1) = (EPS * ES) / max(1e-20, COMS%PE (1) - ES) !blob saturation lwc g/g dry air + + IF (COMS%QV (1) .gt. COMS%QSAT (1) ) THEN + COMS%QC (1) = COMS%QV (1) - COMS%QSAT (1) + COMS%QC (1) !remainder goes into cloud drops + COMS%QV (1) = COMS%QSAT (1) + ENDIF +! + CALL WATERBAL (COMS) +! +RETURN +END SUBROUTINE LBOUND +!------------------------------------------------------------------------------- +! +SUBROUTINE INITIAL (coms,kmt) +! +! ************* SETS UP INITIAL CONDITIONS FOR THE PROBLEM ************ +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: tfreeze = 269.3 +integer :: isub, k, n1, n2, n3, lbuoy, itmp, isubm1 ,kmt +real(kind=kind_phys) :: xn1, xi, es, esat!,ESAT_PR +! +COMS%N=kmt +! initialize temperature structure,to the end of equal spaced sounding, + do k = 1, COMS%N + COMS%TXS (k) = 0.0 + COMS%W (k) = 0.0 + COMS%T (k) = COMS%TE(k) !blob set to environment + COMS%WC(k) = 0.0 + COMS%WT(k) = 0.0 + COMS%QV(k) = COMS%QVENV (k) !blob set to environment + COMS%VTH(k) = 0. !initial rain velocity = 0 + COMS%VTI(k) = 0. !initial ice velocity = 0 + COMS%QH(k) = 0. !no rain + COMS%QI(k) = 0. !no ice + COMS%QC(k) = 0. !no cloud drops +! COMS%PE esta em kPa - ESAT do RAMS esta em mbar = 100 Pa = 0.1 kPa +! ES = 0.1*ESAT (COMS%T(k)) !blob saturation vapor pressure, em kPa +! rotina do plumegen calcula em kPa + ES = ESAT_PR (COMS%T(k)) !blob saturation vapor pressure, em kPa + COMS%EST (k) = ES + COMS%QSAT (k) = (.622 * ES) / (COMS%PE (k) - ES) !saturation lwc g/g +!sam if(.not.coms%pe(k)>0 .or. .not. coms%T(k)>200) then +!sam 1307 format('(1307) bad input to rho at k=',I0,' with pe=',F12.5,' T=',F12.5) +!sam write(0,1307) k,coms%PE(k),coms%T(k) +!sam endif + COMS%RHO (k) = 3483.8 * COMS%PE (k) / COMS%T (k) !dry air density g/m**3 + COMS%VEL_P(k) = 0. + coms%rad_p(k) = 0. + enddo + +! Initialize the entrainment radius, Turner-style plume + coms%radius(1) = coms%rsurf + do k=2,COMS%N + coms%radius(k) = coms%radius(k-1)+(6./5.)*coms%alpha*(coms%zt(k)-coms%zt(k-1)) + enddo +! Initialize the entrainment radius, Turner-style plume + coms%radius(1) = coms%rsurf + coms%rad_p(1) = coms%rsurf + DO k=2,COMS%N + coms%radius(k) = coms%radius(k-1)+(6./5.)*coms%alpha*(coms%zt(k)-coms%zt(k-1)) + coms%rad_p(k) = coms%radius(k) + ENDDO + +! Initialize the viscosity + COMS%VISC (1) = COMS%VISCOSITY + do k=2,COMS%N + !COMS%VISC (k) = COMS%VISCOSITY!max(1.e-3,coms%visc(k-1) - 1.* COMS%VISCOSITY/float(nkp)) + COMS%VISC (k) = max(1.e-3,coms%visc(k-1) - 1.* COMS%VISCOSITY/float(nkp)) + enddo +!-- Initialize gas/concentration + !DO k =10,20 + ! COMS%SC(k) = 20. + !ENDDO + !stop 333 + + CALL LBOUND(COMS) + +RETURN +END SUBROUTINE INITIAL +!------------------------------------------------------------------------------- +! +subroutine damp_grav_wave(ifrom,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) +implicit none +integer nm1,ifrom,deltak +real(kind=kind_phys) dt +real(kind=kind_phys), dimension(nm1) :: w,t,tt,qv,qh,qi,qc,te,pe,qvenv,dummy,zt,zm + +if(ifrom==1) then + call friction(ifrom,nm1,deltak,dt,zt,zm,t,tt ,te) +!call friction(ifrom,nm1,dt,zt,zm,qv,coms%qvt,qvenv) + return +endif + +dummy(:) = 0. +if(ifrom==2) call friction(ifrom,nm1,deltak,dt,zt,zm,w,dummy ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qi,coms%qit ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qh,coms%qht ,dummy) +!call friction(ifrom,nm1,dt,zt,zm,qc,coms%qct ,dummy) +return +end subroutine damp_grav_wave +!------------------------------------------------------------------------------- +! +subroutine friction(ifrom,nm1,deltak,dt,zt,zm,var1,vart,var2) +implicit none +real(kind=kind_phys), dimension(nm1) :: var1,var2,vart,zt,zm +integer k,nfpt,kf,nm1,ifrom,deltak +real(kind=kind_phys) zmkf,ztop,distim,c1,c2,dt + +!nfpt=50 +!kf = nm1 - nfpt +!kf = nm1 - int(deltak/2) + kf = nm1 - int(deltak) + +zmkf = zm(kf) !old: float(kf )*coms%dz +ztop = zm(nm1) +!distim = min(4.*dt,200.) +!distim = 60. + distim = min(3.*dt,60.) + +c1 = 1. / (distim * (ztop - zmkf)) +c2 = dt * c1 + +if(ifrom == 1) then + do k = nm1,2,-1 + if (zt(k) .le. zmkf) cycle + vart(k) = vart(k) + c1 * (zt(k) - zmkf)*(var2(k) - var1(k)) + enddo +elseif(ifrom == 2) then + do k = nm1,2,-1 + if (zt(k) .le. zmkf) cycle + var1(k) = var1(k) + c2 * (zt(k) - zmkf)*(var2(k) - var1(k)) + enddo +endif +return +end subroutine friction +!------------------------------------------------------------------------------- +! +subroutine vel_advectc_plumerise(m1,wc,wt,rho,dzm) + +implicit none +integer :: k,m1 +real(kind=kind_phys), dimension(m1) :: wc,wt,flxw,dzm,rho +real(kind=kind_phys), dimension(m1) :: dn0 ! var local +real(kind=kind_phys) :: c1z + +!dzm(:)= 1./coms%dz + +dn0(1:m1)=rho(1:m1)*1.e-3 ! converte de cgs para mks + +flxw(1) = wc(1) * dn0(1) + +do k = 2,m1-1 + flxw(k) = wc(k) * .5 * (dn0(k) + dn0(k+1)) +enddo + +! Compute advection contribution to W tendency + +c1z = .5 + +do k = 2,m1-2 + + wt(k) = wt(k) & + + c1z * dzm(k) / (dn0(k) + dn0(k+1)) * ( & + (flxw(k) + flxw(k-1)) * (wc(k) + wc(k-1)) & + - (flxw(k) + flxw(k+1)) * (wc(k) + wc(k+1)) & + + (flxw(k+1) - flxw(k-1)) * 2.* wc(k) ) + +enddo + +return +end subroutine vel_advectc_plumerise +!------------------------------------------------------------------------------- +! +subroutine hadvance_plumerise(iac,m1,dt,wc,wt,wp,mintime) + +implicit none +integer :: k,iac +integer :: m1,mintime +real(kind=kind_phys), dimension(m1) :: dummy, wc,wt,wp +real(kind=kind_phys) eps,dt +! It is here that the Asselin filter is applied. For the velocities +! and pressure, this must be done in two stages, the first when +! IAC=1 and the second when IAC=2. + + +eps = .2 +if(mintime == 1) eps=0.5 + +! For both IAC=1 and IAC=2, call PREDICT for U, V, W, and P. +! +call predict_plumerise(m1,wc,wp,wt,dummy,iac,2.*dt,eps) +!print*,'mintime',mintime,eps +!do k=1,m1 +! print*,'W-HAD',k,wc(k),wp(k),wt(k) +!enddo +return +end subroutine hadvance_plumerise +!------------------------------------------------------------------------------- +! +subroutine predict_plumerise(npts,ac,ap,fa,af,iac,dtlp,epsu) +implicit none +integer :: npts,iac,m +real(kind=kind_phys) :: epsu,dtlp +real(kind=kind_phys), dimension(*) :: ac,ap,fa,af + +! For IAC=3, this routine moves the arrays AC and AP forward by +! 1 time level by adding in the prescribed tendency. It also +! applies the Asselin filter given by: + +! {AC} = AC + EPS * (AP - 2 * AC + AF) + +! where AP,AC,AF are the past, current and future time levels of A. +! All IAC=1 does is to perform the {AC} calculation without the AF +! term present. IAC=2 completes the calculation of {AC} by adding +! the AF term only, and advances AC by filling it with input AP +! values which were already updated in ACOUSTC. +! + +if (iac .eq. 1) then + do m = 1,npts + ac(m) = ac(m) + epsu * (ap(m) - 2. * ac(m)) + enddo + return +elseif (iac .eq. 2) then + do m = 1,npts + af(m) = ap(m) + ap(m) = ac(m) + epsu * af(m) + enddo +!elseif (iac .eq. 3) then +! do m = 1,npts +! af(m) = ap(m) + dtlp * fa(m) +! enddo +! if (ngrid .eq. 1 .and. ipara .eq. 0) call cyclic(nzp,nxp,nyp,af,'T') +! do m = 1,npts +! ap(m) = ac(m) + epsu * (ap(m) - 2. * ac(m) + af(m)) +! enddo +endif + +do m = 1,npts + ac(m) = af(m) +enddo +return +end subroutine predict_plumerise +!------------------------------------------------------------------------------- +! +subroutine buoyancy_plumerise(m1, T, TE, QV, QVENV, QH, QI, QC, WT, scr1) +implicit none +integer :: k,m1 +real(kind=kind_phys), parameter :: g = 9.8, eps = 0.622, gama = 0.5 ! mass virtual coeff. +real(kind=kind_phys), dimension(m1) :: T, TE, QV, QVENV, QH, QI, QC, WT, scr1 +real(kind=kind_phys) :: TV,TVE,QWTOTL,umgamai +real(kind=kind_phys), parameter :: mu = 0.15 + +!- orig +umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as + ! das pertubacoes nao-hidrostaticas no campo de pressao + +!- new ! Siesbema et al, 2004 +!umgamai = 1./(1.-2.*mu) + +do k = 2,m1-1 + + TV = T(k) * (1. + (QV(k) /EPS))/(1. + QV(k) ) !blob virtual temp. + TVE = TE(k) * (1. + (QVENV(k)/EPS))/(1. + QVENV(k)) !and environment + + QWTOTL = QH(k) + QI(k) + QC(k) ! QWTOTL*G is drag +!- orig + !scr1(k)= G*( umgamai*( TV - TVE) / TVE - QWTOTL) + scr1(k)= G* umgamai*( (TV - TVE) / TVE - QWTOTL) + + !if(k .lt. 10)print*,'BT',k,TV,TVE,TVE,QWTOTL +enddo + +do k = 2,m1-2 + wt(k) = wt(k)+0.5*(scr1(k)+scr1(k+1)) +! print*,'W-BUO',k,wt(k),scr1(k),scr1(k+1) +enddo + +end subroutine buoyancy_plumerise +!------------------------------------------------------------------------------- +! +subroutine ENTRAINMENT(coms,m1,w,wt,radius,ALPHA) +implicit none +type(plumegen_coms), pointer :: coms +integer :: k,m1 +real(kind=kind_phys), dimension(m1) :: w,wt,radius +REAL(kind=kind_phys) DMDTM,WBAR,RADIUS_BAR,umgamai,DYN_ENTR,ALPHA +real(kind=kind_phys), parameter :: mu = 0.15 ,gama = 0.5 ! mass virtual coeff. + +!- new - Siesbema et al, 2004 +!umgamai = 1./(1.-2.*mu) + +!- orig +!umgamai = 1 +umgamai = 1./(1.+gama) ! compensa a falta do termo de aceleracao associado `as + ! das pertubacoes nao-hidrostaticas no campo de pressao + +! +!-- ALPHA/RADIUS(COMS%L) = (1/M)DM/COMS%DZ (W 14a) + do k=2,m1-1 + +!-- for W: WBAR is only W(k) +! WBAR=0.5*(W(k)+W(k-1)) + WBAR=W(k) + RADIUS_BAR = 0.5*(RADIUS(k) + RADIUS(k-1)) +! orig + !DMDTM = 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/COMS%DT + DMDTM = umgamai * 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/COMS%DT + +!-- DMDTM*W(COMS%L) entrainment, + wt(k) = wt(k) - DMDTM*ABS (WBAR) + !print*,'W-ENTR=',k,w(k),- DMDTM*ABS (WBAR) + + !if(COMS%VEL_P (k) - COMS%VEL_E (k) > 0.) cycle + + !- dynamic entrainment + DYN_ENTR = (2./3.1416)*0.5*ABS (COMS%VEL_P(k)-COMS%VEL_E(k)+COMS%VEL_P(k-1)-COMS%VEL_E(k-1)) /RADIUS_BAR + + wt(k) = wt(k) - DYN_ENTR*ABS (WBAR) + + !- entraiment acceleration for output only + !dwdt_entr(k) = - DMDTM*ABS (WBAR)- DYN_ENTR*ABS (WBAR) + enddo +end subroutine ENTRAINMENT +!------------------------------------------------------------------------------- +! +subroutine scl_advectc_plumerise(coms,varn,mzp) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer :: mzp +character(len=*) :: varn +real(kind=kind_phys) :: dtlto2 +integer :: k + +! wp => w +!- Advect scalars + dtlto2 = .5 * coms%dt +! coms%vt3dc(1) = (coms%w(1) + coms%wc(1)) * dtlto2 * coms%dne(1) + coms%vt3dc(1) = (coms%w(1) + coms%wc(1)) * dtlto2 * coms%rho(1)*1.e-3!converte de CGS p/ MKS + coms%vt3df(1) = .5 * (coms%w(1) + coms%wc(1)) * dtlto2 * coms%dzm(1) + + do k = 2,mzp +! coms%vt3dc(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * (coms%dne(k) + coms%dne(k+1)) + coms%vt3dc(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * (coms%rho(k) + coms%rho(k+1))*1.e-3 + coms%vt3df(k) = (coms%w(k) + coms%wc(k)) * dtlto2 *.5 * coms%dzm(k) + !print*,'coms%vt3df-coms%vt3dc',k,coms%vt3dc(k),coms%vt3df(k) + enddo + + +!-srf-24082005 +! do k = 1,mzp-1 + do k = 1,mzp + coms%vctr1(k) = (coms%zt(k+1) - coms%zm(k)) * coms%dzm(k) + coms%vctr2(k) = (coms%zm(k) - coms%zt(k)) * coms%dzm(k) +! coms%vt3dk(k) = coms%dzt(k) / coms%dne(k) + coms%vt3dk(k) = coms%dzt(k) /(coms%rho(k)*1.e-3) + !print*,'Coms%Vt3dk',k,coms%dzt(k) , coms%dne(k) + enddo + +! scalarp => scalar_tab(coms%n,ngrid)%var_p +! scalart => scalar_tab(coms%n,ngrid)%var_t + +!- temp advection tendency (COMS%TT) + coms%scr1=COMS%T + call fa_zc_plumerise(mzp & + ,COMS%T ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%T,coms%scr1(1),COMS%TT,coms%dt) + +!- water vapor advection tendency (COMS%QVT) + coms%scr1=COMS%QV + call fa_zc_plumerise(mzp & + ,COMS%QV ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QV,coms%scr1(1),COMS%QVT,coms%dt) + +!- liquid advection tendency (COMS%QCT) + coms%scr1=COMS%QC + call fa_zc_plumerise(mzp & + ,COMS%QC ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QC,coms%scr1(1),COMS%QCT,coms%dt) + +!- ice advection tendency (COMS%QIT) + coms%scr1=COMS%QI + call fa_zc_plumerise(mzp & + ,COMS%QI ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QI,coms%scr1(1),COMS%QIT,coms%dt) + +!- hail/rain advection tendency (COMS%QHT) +! if(ak1 > 0. .or. ak2 > 0.) then + + coms%scr1=COMS%QH + call fa_zc_plumerise(mzp & + ,COMS%QH ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%QH,coms%scr1(1),COMS%QHT,coms%dt) +! endif + !- horizontal wind advection tendency (COMS%VEL_T) + coms%scr1=COMS%VEL_P + call fa_zc_plumerise(mzp & + ,COMS%VEL_P ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%VEL_P,coms%scr1(1),COMS%VEL_T,coms%dt) + + !- vertical radius transport + + coms%scr1=coms%rad_p + call fa_zc_plumerise(mzp & + ,coms%rad_p ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,coms%rad_p,coms%scr1(1),coms%rad_t,coms%dt) + + + return +! +!- gas/particle advection tendency (COMS%SCT) +! if(varn == 'SC')return + coms%scr1=COMS%SC + call fa_zc_plumerise(mzp & + ,COMS%SC ,coms%scr1 (1) & + ,coms%vt3dc (1) ,coms%vt3df (1) & + ,coms%vt3dg (1) ,coms%vt3dk (1) & + ,coms%vctr1,coms%vctr2 ) + + call advtndc_plumerise(mzp,COMS%SC,coms%scr1(1),COMS%SCT,coms%dt) + + +return +end subroutine scl_advectc_plumerise +!------------------------------------------------------------------------------- +! +subroutine fa_zc_plumerise(m1,scp,scr1,vt3dc,vt3df,vt3dg,vt3dk,vctr1,vctr2) + +implicit none +integer :: m1,k +real(kind=kind_phys) :: dfact +real(kind=kind_phys), dimension(m1) :: scp,scr1,vt3dc,vt3df,vt3dg,vt3dk +real(kind=kind_phys), dimension(m1) :: vctr1,vctr2 + +dfact = .5 + +! Compute scalar flux VT3DG + do k = 1,m1-1 + vt3dg(k) = vt3dc(k) & + * (vctr1(k) * scr1(k) & + + vctr2(k) * scr1(k+1) & + + vt3df(k) * (scr1(k) - scr1(k+1))) + enddo + +! Modify fluxes to retain positive-definiteness on scalar quantities. +! If a flux will remove 1/2 quantity during a timestep, +! reduce to first order flux. This will remain positive-definite +! under the assumption that ABS(CFL(i)) + ABS(CFL(i-1)) < 1.0 if +! both fluxes are evacuating the box. + +do k = 1,m1-1 + if (vt3dc(k) .gt. 0.) then + if (vt3dg(k) * vt3dk(k) .gt. dfact * scr1(k)) then + vt3dg(k) = vt3dc(k) * scr1(k) + endif + elseif (vt3dc(k) .lt. 0.) then + if (-vt3dg(k) * vt3dk(k+1) .gt. dfact * scr1(k+1)) then + vt3dg(k) = vt3dc(k) * scr1(k+1) + endif + endif + +enddo + +! Compute flux divergence +do k = 2,m1-1 + scr1(k) = scr1(k) & + + vt3dk(k) * ( vt3dg(k-1) - vt3dg(k) & + + scp (k) * ( vt3dc(k) - vt3dc(k-1))) +enddo +return +end subroutine fa_zc_plumerise +!------------------------------------------------------------------------------- +! +subroutine advtndc_plumerise(m1,scp,sca,sct,dtl) +implicit none +integer :: m1,k +real(kind=kind_phys) :: dtl,dtli +real(kind=kind_phys), dimension(m1) :: scp,sca,sct + +dtli = 1. / dtl +do k = 2,m1-1 + sct(k) = sct(k) + (sca(k)-scp(k)) * dtli +enddo +return +end subroutine advtndc_plumerise +!------------------------------------------------------------------------------- +! +subroutine tend0_plumerise(coms) +implicit none +type(plumegen_coms), pointer :: coms + coms%wt(1:coms%nm1) = 0. + coms%tt(1:coms%nm1) = 0. +coms%qvt(1:coms%nm1) = 0. +coms%qct(1:coms%nm1) = 0. +coms%qht(1:coms%nm1) = 0. +coms%qit(1:coms%nm1) = 0. +coms%vel_t(1:coms%nm1) = 0. +coms%rad_t(1:coms%nm1) = 0. +!coms%sct(1:coms%nm1) = 0. +end subroutine tend0_plumerise + +! **************************************************************** + +subroutine scl_misc(coms,m1) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), parameter :: g = 9.81, cp=1004. +integer m1,k +real(kind=kind_phys) dmdtm + + do k=2,m1-1 + COMS%WBAR = 0.5*(COMS%W(k)+COMS%W(k-1)) +!-- dry adiabat + COMS%ADIABAT = - COMS%WBAR * G / CP +! +!-- entrainment + DMDTM = 2. * COMS%ALPHA * ABS (COMS%WBAR) / COMS%RADIUS (k) != (1/M)DM/COMS%DT + +!-- tendency temperature = adv + adiab + entrainment + COMS%TT(k) = COMS%TT(K) + COMS%ADIABAT - DMDTM * ( COMS%T (k) - COMS%TE (k) ) + +!-- tendency water vapor = adv + entrainment + COMS%QVT(K) = COMS%QVT(K) - DMDTM * ( COMS%QV (k) - COMS%QVENV (k) ) + + COMS%QCT(K) = COMS%QCT(K) - DMDTM * ( COMS%QC (k) ) + COMS%QHT(K) = COMS%QHT(K) - DMDTM * ( COMS%QH (k) ) + COMS%QIT(K) = COMS%QIT(K) - DMDTM * ( COMS%QI (k) ) + + !-- tendency horizontal speed = adv + entrainment + COMS%VEL_T(K) = COMS%VEL_T(K) - DMDTM * ( COMS%VEL_P (k) - COMS%VEL_E (k) ) + + !-- tendency horizontal speed = adv + entrainment + coms%rad_t(K) = coms%rad_t(K) + 0.5*DMDTM*(6./5.)*COMS%RADIUS (k) +!-- tendency gas/particle = adv + entrainment +! COMS%SCT(K) = COMS%SCT(K) - DMDTM * ( COMS%SC (k) - COMS%SCE (k) ) + +enddo +end subroutine scl_misc +! **************************************************************** + + SUBROUTINE scl_dyn_entrain(m1,nkp,wbar,w,adiabat,alpha,radius,tt,t,te,qvt,qv,qvenv,qct,qc,qht,qh,qit,qi,& + vel_e,vel_p,vel_t,rad_p,rad_t) + implicit none + + INTEGER , INTENT(IN) :: m1 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL(kind=kind_phys) , INTENT(INOUT) :: wbar + REAL(kind=kind_phys) , INTENT(IN) :: w(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: adiabat + REAL(kind=kind_phys) , INTENT(IN) :: alpha + REAL(kind=kind_phys) , INTENT(IN) :: radius(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: tt(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: t(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: te(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qvt(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qv(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qvenv(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qct(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qc(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qht(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qh(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: qit(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: qi(nkp) + + REAL(kind=kind_phys) , INTENT(IN) :: vel_e(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: vel_p(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: vel_t(nkp) + REAL(kind=kind_phys) , INTENT(INOUT) :: rad_T(nkp) + REAL(kind=kind_phys) , INTENT(IN) :: rad_p(nkp) + + real(kind=kind_phys), parameter :: g = 9.81, cp=1004., pi=3.1416 + + integer k + real(kind=kind_phys) dmdtm + + DO k=2,m1-1 + ! + !-- tendency horizontal radius from dyn entrainment + !rad_t(K) = rad_t(K) + (vel_e(k)-vel_p(k)) /pi + rad_t(K) = rad_t(K) + ABS((vel_e(k)-vel_p(k)))/pi + + !-- entrainment + !DMDTM = (2./3.1416) * (VEL_E (k) - VEL_P (k)) / RADIUS (k) + DMDTM = (2./3.1416) * ABS(VEL_E (k) - VEL_P (k)) / RADIUS (k) + + !-- tendency horizontal speed from dyn entrainment + VEL_T(K) = VEL_T(K) - DMDTM * ( VEL_P (k) - VEL_E (k) ) + + ! if(VEL_P (k) - VEL_E (k) > 0.) cycle + + !-- tendency temperature from dyn entrainment + TT(k) = TT(K) - DMDTM * ( T (k) - TE (k) ) + + !-- tendency water vapor from dyn entrainment + QVT(K) = QVT(K) - DMDTM * ( QV (k) - QVENV (k) ) + + QCT(K) = QCT(K) - DMDTM * ( QC (k) ) + QHT(K) = QHT(K) - DMDTM * ( QH (k) ) + QIT(K) = QIT(K) - DMDTM * ( QI (k) ) + + !-- tendency gas/particle from dyn entrainment + ! COMS%SCT(K) = COMS%SCT(K) - DMDTM * ( SC (k) - COMS%SCE (k) ) + + ENDDO + END SUBROUTINE scl_dyn_entrain + +! **************************************************************** + +subroutine visc_W(coms,m1,deltak,kmt) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k,deltak,kmt,m2 +real(kind=kind_phys) dz1t,dz1m,dz2t,dz2m,d2wdz,d2tdz ,d2qvdz ,d2qhdz ,d2qcdz ,d2qidz ,d2scdz, & + d2vel_pdz,d2rad_dz +!sam real(kind=kind_phys) :: old_tt +logical, save, volatile :: printed = .false. + + +!srf--- 17/08/2005 +!m2=min(m1+deltak,kmt) +m2=min(m1,kmt) + +!do k=2,m1-1 +do k=2,m2-1 + DZ1T = 0.5*(COMS%ZT(K+1)-COMS%ZT(K-1)) + DZ2T = COMS%VISC (k) / (DZ1T * DZ1T) + DZ1M = 0.5*(COMS%ZM(K+1)-COMS%ZM(K-1)) + DZ2M = COMS%VISC (k) / (DZ1M * DZ1M) + D2WDZ = (COMS%W (k + 1) - 2 * COMS%W (k) + COMS%W (k - 1) ) * DZ2M + D2TDZ = (COMS%T (k + 1) - 2 * COMS%T (k) + COMS%T (k - 1) ) * DZ2T + D2QVDZ = (COMS%QV (k + 1) - 2 * COMS%QV (k) + COMS%QV (k - 1) ) * DZ2T + D2QHDZ = (COMS%QH (k + 1) - 2 * COMS%QH (k) + COMS%QH (k - 1) ) * DZ2T + D2QCDZ = (COMS%QC (k + 1) - 2 * COMS%QC (k) + COMS%QC (k - 1) ) * DZ2T + D2QIDZ = (COMS%QI (k + 1) - 2 * COMS%QI (k) + COMS%QI (k - 1) ) * DZ2T + !D2SCDZ = (COMS%SC (k + 1) - 2 * COMS%SC (k) + COMS%SC (k - 1) ) * DZ2T + d2vel_pdz=(coms%vel_p (k + 1) - 2 * coms%vel_p (k) + coms%vel_p (k - 1) ) * DZ2T + d2rad_dz =(coms%rad_p (k + 1) - 2 * coms%rad_p (k) + coms%rad_p (k - 1) ) * DZ2T + + COMS%WT(k) = COMS%WT(k) + D2WDZ +!sam old_tt=coms%tt(k) + COMS%TT(k) = COMS%TT(k) + D2TDZ +!sam if(.not. coms%tt(k)>-10 .and. .not. printed) then +!sam 1924 format("(1924) visc_W Bad TT at k=",I0," TT=",F12.5," old_TT=",F12.5," d2tdz=",F12.5," visc=",F12.5) +!sam 1925 format("(1925) T = ",F12.5,",",F12.5,",",F12.5," ZT=",F12.5,",",F12.5) +!sam write(0,1924) k, COMS%TT(k), old_TT, d2tdz, coms%visc(k) +!sam write(0,1925) coms%T(k-1),coms%T(k),coms%T(k+1),coms%ZT(k-1),coms%ZT(k+1) +!sam printed = .true. +!sam endif + COMS%QVT(k) = COMS%QVT(k) + D2QVDZ + COMS%QCT(k) = COMS%QCT(k) + D2QCDZ + COMS%QHT(k) = COMS%QHT(k) + D2QHDZ + COMS%QIT(k) = COMS%QIT(k) + D2QIDZ + coms%vel_t(k) = coms%vel_t(k) + d2vel_pdz + coms%rad_t(k) = coms%rad_t(k) + d2rad_dz + !COMS%SCT(k) = COMS%SCT(k) + D2SCDZ + !print*,'W-COMS%VISC=',k,D2WDZ +enddo + +end subroutine visc_W + +! **************************************************************** + +subroutine update_plumerise(coms,m1,varn) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k +character(len=*) :: varn +!sam real(kind_phys) :: old_t + +if(varn == 'W') then + + do k=2,m1-1 + COMS%W(k) = COMS%W(k) + COMS%WT(k) * COMS%DT + enddo + return + +else +do k=2,m1-1 +!sam old_t = coms%t(k) + COMS%T(k) = COMS%T(k) + COMS%TT(k) * COMS%DT +!sam if(.not. coms%t(k)>200) then +!sam 1921 format("(1921) update_plumerise Bad T at k=",I0," T=",F12.5," old_T=",F12.5," TT=",F12.5," DT=",F12.5) +!sam write(0,1921) k, COMS%T(k), old_T, coms%tt(k), coms%dt +!sam endif + + COMS%QV(k) = COMS%QV(k) + COMS%QVT(k) * COMS%DT + + COMS%QC(k) = COMS%QC(k) + COMS%QCT(k) * COMS%DT !cloud drops travel with air + COMS%QH(k) = COMS%QH(k) + COMS%QHT(k) * COMS%DT + COMS%QI(k) = COMS%QI(k) + COMS%QIT(k) * COMS%DT +! COMS%SC(k) = COMS%SC(k) + COMS%SCT(k) * COMS%DT + +!srf---18jun2005 + COMS%QV(k) = max(0., COMS%QV(k)) + COMS%QC(k) = max(0., COMS%QC(k)) + COMS%QH(k) = max(0., COMS%QH(k)) + COMS%QI(k) = max(0., COMS%QI(k)) + + COMS%VEL_P(k) = COMS%VEL_P(k) + COMS%VEL_T(k) * COMS%DT + coms%rad_p(k) = coms%rad_p(k) + coms%rad_t(k) * COMS%DT +! COMS%SC(k) = max(0., COMS%SC(k)) + + enddo +endif +end subroutine update_plumerise +!------------------------------------------------------------------------------- +! +subroutine fallpart(coms,m1) +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +integer m1,k +real(kind=kind_phys) vtc, dfhz,dfiz,dz1 +!srf================================== +! verificar se o gradiente esta correto +! +!srf================================== +! +! XNO=1.E7 [m**-4] median volume diameter raindrop,Kessler +! VC = 38.3/(XNO**.125), median volume fallspeed eqn., Kessler +! for ice, see (OT18), use F0=0.75 per argument there. coms%rho*q +! values are in g/m**3, velocities in m/s + +real(kind=kind_phys), PARAMETER :: VCONST = 5.107387, EPS = 0.622, F0 = 0.75 +real(kind=kind_phys), PARAMETER :: G = 9.81, CP = 1004. +! +do k=2,m1-1 +!sam if(.not. coms%rho(k)>1e-20) then +!sam 33 format('(33) Bad density at k=',I0,' rho=',F12.5,' T=',F12.5,' PE=',F12.5,' test=',I0) +!sam write(0,33) k,coms%rho(k),coms%T(k),coms%PE(k),coms%testval +!sam endif + VTC = VCONST * COMS%RHO (k) **.125 ! median volume fallspeed (KTable4) + +! hydrometeor assembly velocity calculations (K Table4) +! COMS%VTH(k)=-VTC*COMS%QH(k)**.125 !median volume fallspeed, water + COMS%VTH (k) = - 4. !small variation with coms%qh + + COMS%VHREL = COMS%W (k) + COMS%VTH (k) !relative to surrounding cloud + +! rain ventilation coefficient for evaporation + COMS%CVH(k) = 1.6 + 0.57E-3 * (ABS (COMS%VHREL) ) **1.5 +! +! COMS%VTI(k)=-VTC*F0*COMS%QI(k)**.125 !median volume fallspeed,ice + COMS%VTI (k) = - 3. !small variation with coms%qi + + COMS%VIREL = COMS%W (k) + COMS%VTI (k) !relative to surrounding cloud +! +! ice ventilation coefficient for sublimation + COMS%CVI(k) = 1.6 + 0.57E-3 * (ABS (COMS%VIREL) ) **1.5 / F0 +! +! + IF (COMS%VHREL.GE.0.0) THEN + DFHZ=COMS%QH(k)*(COMS%RHO(k )*COMS%VTH(k )-COMS%RHO(k-1)*COMS%VTH(k-1))/COMS%RHO(k-1) + ELSE + DFHZ=COMS%QH(k)*(COMS%RHO(k+1)*COMS%VTH(k+1)-COMS%RHO(k )*COMS%VTH(k ))/COMS%RHO(k) + ENDIF + ! + ! + IF (COMS%VIREL.GE.0.0) THEN + DFIZ=COMS%QI(k)*(COMS%RHO(k )*COMS%VTI(k )-COMS%RHO(k-1)*COMS%VTI(k-1))/COMS%RHO(k-1) + ELSE + DFIZ=COMS%QI(k)*(COMS%RHO(k+1)*COMS%VTI(k+1)-COMS%RHO(k )*COMS%VTI(k ))/COMS%RHO(k) + ENDIF + + DZ1=COMS%ZM(K)-COMS%ZM(K-1) + + coms%qht(k) = coms%qht(k) - DFHZ / DZ1 !hydrometeors don't + coms%qit(k) = coms%qit(k) - DFIZ / DZ1 !nor does ice? hail, what about + +enddo +end subroutine fallpart + +! ********************************************************************* +SUBROUTINE WATERBAL(coms) +implicit none +type(plumegen_coms), pointer :: coms + +!use module_zero_plumegen_coms +! + +IF (COMS%QC (COMS%L) .LE.1.0E-10) COMS%QC (COMS%L) = 0. !DEFEAT UNDERFLOW PROBLEM +IF (COMS%QH (COMS%L) .LE.1.0E-10) COMS%QH (COMS%L) = 0. +IF (COMS%QI (COMS%L) .LE.1.0E-10) COMS%QI (COMS%L) = 0. +! +CALL EVAPORATE(COMS) !vapor to cloud,cloud to vapor +! +CALL SUBLIMATE(COMS) !vapor to ice +! +CALL GLACIATE(COMS) !rain to ice + +CALL MELT(COMS) !ice to rain +! +!if(ak1 > 0. .or. ak2 > 0.) & +CALL CONVERT(COMS) !(auto)conversion and accretion +!CALL CONVERT2 () !(auto)conversion and accretion +! + +RETURN +END SUBROUTINE WATERBAL +! ********************************************************************* +SUBROUTINE EVAPORATE(coms) +! +!- evaporates cloud,rain and ice to saturation +! +!use module_zero_plumegen_coms +implicit none +type(plumegen_coms), pointer :: coms +! +! XNO=10.0E06 +! HERC = 1.93*1.E-6*XN035 !evaporation constant +! +real(kind=kind_phys), PARAMETER :: HERC = 5.44E-4, CP = 1.004, HEATCOND = 2.5E3 +real(kind=kind_phys), PARAMETER :: HEATSUBL = 2834., TMELT = 273., TFREEZE = 269.3 + +real(kind=kind_phys), PARAMETER :: FRC = HEATCOND / CP, SRC = HEATSUBL / CP + +real(kind=kind_phys) :: evhdt, evidt, evrate, evap, sd, quant, dividend, divisor, devidt + +! +! +SD = COMS%QSAT (COMS%L) - COMS%QV (COMS%L) !vapor deficit +IF (SD.EQ.0.0) RETURN +!IF (abs(SD).lt.1.e-7) RETURN + + +EVHDT = 0. +EVIDT = 0. +!evrate =0.; evap=0.; sd=0.0; quant=0.0; dividend=0.0; divisor=0.0; devidt=0.0 + +EVRATE = ABS (COMS%WBAR * COMS%DQSDZ) !evaporation rate (Kessler 8.32) +EVAP = EVRATE * COMS%DT !what we can get in DT + + +IF (SD.LE.0.0) THEN ! condense. SD is negative + + IF (EVAP.GE.ABS (SD) ) THEN !we get it all + + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD !deficit,remember? + COMS%QV (COMS%L) = COMS%QSAT(COMS%L) !set the vapor to saturation + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !heat gained through condensation + !per gram of dry air + RETURN + + ELSE + + COMS%QC (COMS%L) = COMS%QC (COMS%L) + EVAP !get what we can in DT + COMS%QV (COMS%L) = COMS%QV (COMS%L) - EVAP !remove it from the vapor + COMS%T (COMS%L) = COMS%T (COMS%L) + EVAP * FRC !get some heat + + RETURN + + ENDIF +! +ELSE !SD is positive, need some water +! +! not saturated. saturate if possible. use everything in order +! cloud, rain, ice. SD is positive + + IF (EVAP.LE.COMS%QC (COMS%L) ) THEN !enough cloud to last DT +! + + IF (SD.LE.EVAP) THEN !enough time to saturate + + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD !remove cloud + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !cool the parcel + RETURN !done +! + + ELSE !not enough time + + SD = SD-EVAP !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVAP !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVAP * FRC !lose heat + COMS%QC (COMS%L) = COMS%QC (COMS%L) - EVAP !lose cloud + !go on to rain. + ENDIF +! + ELSE !not enough cloud to last DT +! + IF (SD.LE.COMS%QC (COMS%L) ) THEN !but there is enough to sat + + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QC (COMS%L) = COMS%QC (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC + RETURN + + ELSE !not enough to sat + SD = SD-COMS%QC (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QC (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QC (COMS%L) * FRC + COMS%QC (COMS%L) = 0.0 !all gone + + ENDIF !on to rain + ENDIF !finished with cloud +! +! but still not saturated, so try to use some rain +! this is tricky, because we only have time DT to evaporate. if there +! is enough rain, we can evaporate it for dt. ice can also sublimate +! at the same time. there is a compromise here.....use rain first, then +! ice. saturation may not be possible in one DT time. +! rain evaporation rate (W12),(OT25),(K Table 4). evaporate rain first +! sd is still positive or we wouldn't be here. + + + IF (COMS%QH (COMS%L) .LE.1.E-10) GOTO 33 + +!srf-25082005 +! QUANT = ( COMS%QC (COMS%L) + COMS%QV (COMS%L) - COMS%QSAT (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 + QUANT = ( COMS%QSAT (COMS%L)- COMS%QC (COMS%L) - COMS%QV (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 +! + EVHDT = (COMS%DT * HERC * (QUANT) * (COMS%QH (COMS%L) * COMS%RHO (COMS%L) ) **.65) / COMS%RHO (COMS%L) +! rain evaporation in time DT + + IF (EVHDT.LE.COMS%QH (COMS%L) ) THEN !enough rain to last DT + + IF (SD.LE.EVHDT) THEN !enough time to saturate + COMS%QH (COMS%L) = COMS%QH (COMS%L) - SD !remove rain + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC !cool the parcel + + RETURN !done +! + ELSE !not enough time + SD = SD-EVHDT !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVHDT !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVHDT * FRC !lose heat + COMS%QH (COMS%L) = COMS%QH (COMS%L) - EVHDT !lose rain + + ENDIF !go on to ice. +! + ELSE !not enough rain to last DT +! + IF (SD.LE.COMS%QH (COMS%L) ) THEN !but there is enough to sat + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QH (COMS%L) = COMS%QH (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * FRC + RETURN +! + ELSE !not enough to sat + SD = SD-COMS%QH (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QH (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QH (COMS%L) * FRC + COMS%QH (COMS%L) = 0.0 !all gone + + ENDIF !on to ice +! + + ENDIF !finished with rain +! +! +! now for ice +! equation from (OT); correction factors for units applied +! + 33 continue + IF (COMS%QI (COMS%L) .LE.1.E-10) RETURN !no ice there +! + DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (SD / COMS%QSAT (COMS%L) & + - 1) * (COMS%QI (COMS%L) **0.525) * 1.13 + DIVISOR = 7.E5 + 4.1E6 / (10. * COMS%EST (COMS%L) ) + + DEVIDT = - COMS%CVI(COMS%L) * DIVIDEND / DIVISOR !rate of change + + EVIDT = DEVIDT * COMS%DT !what we could get +! +! logic here is identical to rain. could get fancy and make subroutine +! but duplication of code is easier. God bless the screen editor. +! + + IF (EVIDT.LE.COMS%QI (COMS%L) ) THEN !enough ice to last DT +! + + IF (SD.LE.EVIDT) THEN !enough time to saturate + COMS%QI (COMS%L) = COMS%QI (COMS%L) - SD !remove ice + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !saturate + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * SRC !cool the parcel + + RETURN !done +! + + ELSE !not enough time + + SD = SD-EVIDT !use what there is + COMS%QV (COMS%L) = COMS%QV (COMS%L) + EVIDT !add vapor + COMS%T (COMS%L) = COMS%T (COMS%L) - EVIDT * SRC !lose heat + COMS%QI (COMS%L) = COMS%QI (COMS%L) - EVIDT !lose ice + + ENDIF !go on,unsatisfied +! + ELSE !not enough ice to last DT +! + IF (SD.LE.COMS%QI (COMS%L) ) THEN !but there is enough to sat + + COMS%QV (COMS%L) = COMS%QSAT (COMS%L) !use it + COMS%QI (COMS%L) = COMS%QI (COMS%L) - SD + COMS%T (COMS%L) = COMS%T (COMS%L) - SD * SRC + + RETURN +! + ELSE !not enough to sat + SD = SD-COMS%QI (COMS%L) + COMS%QV (COMS%L) = COMS%QV (COMS%L) + COMS%QI (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) - COMS%QI (COMS%L) * SRC + COMS%QI (COMS%L) = 0.0 !all gone + + ENDIF !on to better things + !finished with ice + ENDIF +! +ENDIF !finished with the SD decision +! +RETURN +! +END SUBROUTINE EVAPORATE +! +! ********************************************************************* +SUBROUTINE CONVERT (coms) +! +!- ACCRETION AND AUTOCONVERSION +! +implicit none +type(plumegen_coms), pointer :: coms + +!use module_zero_plumegen_coms +! +real(kind=kind_phys), PARAMETER :: AK1 = 0.001 !conversion rate constant +real(kind=kind_phys), PARAMETER :: AK2 = 0.0052 !collection (accretion) rate +real(kind=kind_phys), PARAMETER :: TH = 0.5 !Kessler threshold +integer, PARAMETER :: iconv = 1 !- Kessler conversion (=0) + +!real(kind=kind_phys), parameter :: ANBASE = 50.!*1.e+6 !Berry-number at cloud base #/m^3(maritime) + real(kind=kind_phys), parameter :: ANBASE =100000.!*1.e+6 !Berry-number at cloud base #/m^3(continental) +!real(kind=kind_phys), parameter :: BDISP = 0.366 !Berry--size dispersion (maritime) + real(kind=kind_phys), parameter :: BDISP = 0.146 !Berry--size dispersion (continental) +real(kind=kind_phys), parameter :: TFREEZE = 269.3 !ice formation temperature +! +real(kind=kind_phys) :: accrete, con, q, h, bc1, bc2, total + + +IF (COMS%T (COMS%L) .LE. TFREEZE) RETURN !process not allowed above ice +! +IF (COMS%QC (COMS%L) .EQ. 0. ) RETURN + +ACCRETE = 0. +CON = 0. +Q = COMS%RHO (COMS%L) * COMS%QC (COMS%L) +H = COMS%RHO (COMS%L) * COMS%QH (COMS%L) +! +! selection rules +! +! +IF (COMS%QH (COMS%L) .GT. 0. ) ACCRETE = AK2 * Q * (H**.875) !accretion, Kessler +! +IF (ICONV.NE.0) THEN !select Berry or Kessler +! +!old BC1 = 120. +!old BC2 = .0266 * ANBASE * 60. +!old CON = BDISP * Q * Q * Q / (BC1 * Q * BDISP + BC2) + + CON = Q*Q*Q*BDISP/(60.*(5.*Q*BDISP+0.0366*ANBASE)) +! +ELSE +! +! CON = AK1 * (Q - TH) !Kessler autoconversion rate +! +! IF (CON.LT.0.0) CON = 0.0 !havent reached threshold + + CON = max(0.,AK1 * (Q - TH)) ! versao otimizada +! +ENDIF +! +! +TOTAL = (CON + ACCRETE) * COMS%DT / COMS%RHO (COMS%L) + +! +IF (TOTAL.LT.COMS%QC (COMS%L) ) THEN +! + COMS%QC (COMS%L) = COMS%QC (COMS%L) - TOTAL + COMS%QH (COMS%L) = COMS%QH (COMS%L) + TOTAL !no phase change involved + RETURN +! +ELSE +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + COMS%QC (COMS%L) !uses all there is + COMS%QC (COMS%L) = 0.0 +! +ENDIF +! +RETURN +! +END SUBROUTINE CONVERT +! +!********************************************************************** +! +SUBROUTINE SUBLIMATE(coms) +! +implicit none +type(plumegen_coms), pointer :: coms + +! ********************* VAPOR TO ICE (USE EQUATION OT22)*************** +!use module_zero_plumegen_coms +! +real(kind=kind_phys), PARAMETER :: EPS = 0.622, HEATFUS = 334., HEATSUBL = 2834., CP = 1.004 +real(kind=kind_phys), PARAMETER :: SRC = HEATSUBL / CP, FRC = HEATFUS / CP, TMELT = 273.3 +real(kind=kind_phys), PARAMETER :: TFREEZE = 269.3 + +real(kind=kind_phys) ::dtsubh, dividend,divisor, subl +! +DTSUBH = 0. +! +!selection criteria for sublimation +IF (COMS%T (COMS%L) .GT. TFREEZE ) RETURN +IF (COMS%QV (COMS%L) .LE. COMS%QSAT (COMS%L) ) RETURN +! +! from (OT); correction factors for units applied +! + DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (COMS%QV (COMS%L) / COMS%QSAT (COMS%L) & + - 1) * (COMS%QI (COMS%L) **0.525) * 1.13 + DIVISOR = 7.E5 + 4.1E6 / (10. * COMS%EST (COMS%L) ) +! + + DTSUBH = ABS (DIVIDEND / DIVISOR) !sublimation rate + SUBL = DTSUBH * COMS%DT !and amount possible +! +! again check the possibilities +! +IF (SUBL.LT.COMS%QV (COMS%L) ) THEN +! + COMS%QV (COMS%L) = COMS%QV (COMS%L) - SUBL !lose vapor + COMS%QI (COMS%L) = COMS%QI (COMS%L) + SUBL !gain ice + COMS%T (COMS%L) = COMS%T (COMS%L) + SUBL * SRC !energy change, warms air + + RETURN +! +ELSE +! + COMS%QI (COMS%L) = COMS%QV (COMS%L) !use what there is + COMS%T (COMS%L) = COMS%T (COMS%L) + COMS%QV (COMS%L) * SRC !warm the air + COMS%QV (COMS%L) = 0.0 +! +ENDIF +! +RETURN +END SUBROUTINE SUBLIMATE +! +! ********************************************************************* +! +SUBROUTINE GLACIATE (coms) +! +! *********************** CONVERSION OF RAIN TO ICE ******************* +! uses equation OT 16, simplest. correction from W not applied, but +! vapor pressure differences are supplied. +! +!use module_zero_plumegen_coms +! +implicit none +type(plumegen_coms), pointer :: coms +real(kind=kind_phys), PARAMETER :: HEATFUS = 334., CP = 1.004, EPS = 0.622, HEATSUBL = 2834. +real(kind=kind_phys), PARAMETER :: FRC = HEATFUS / CP, FRS = HEATSUBL / CP, TFREEZE = 269.3 +real(kind=kind_phys), PARAMETER :: GLCONST = 0.025 !glaciation time constant, 1/sec +real(kind=kind_phys) dfrzh +! + + DFRZH = 0. !rate of mass gain in ice +! +!selection rules for glaciation +IF (COMS%QH (COMS%L) .LE. 0. ) RETURN +IF (COMS%QV (COMS%L) .LT. COMS%QSAT (COMS%L) ) RETURN +IF (COMS%T (COMS%L) .GT. TFREEZE ) RETURN +! +! NT=TMELT-COMS%T(COMS%L) +! IF (NT.GT.50) NT=50 +! + + DFRZH = COMS%DT * GLCONST * COMS%QH (COMS%L) ! from OT(16) +! +IF (DFRZH.LT.COMS%QH (COMS%L) ) THEN +! + COMS%QI (COMS%L) = COMS%QI (COMS%L) + DFRZH + COMS%QH (COMS%L) = COMS%QH (COMS%L) - DFRZH + COMS%T (COMS%L) = COMS%T (COMS%L) + FRC * DFRZH !warms air + + + RETURN +! +ELSE +! + COMS%QI (COMS%L) = COMS%QI (COMS%L) + COMS%QH (COMS%L) + COMS%T (COMS%L) = COMS%T (COMS%L) + FRC * COMS%QH (COMS%L) + COMS%QH (COMS%L) = 0.0 + + !print*,'8',coms%l,coms%qi(coms%l), COMS%QH (COMS%L) +! +ENDIF +! +RETURN +! +END SUBROUTINE GLACIATE +! +! +! ********************************************************************* +SUBROUTINE MELT(coms) +! +! ******************* MAKES WATER OUT OF ICE ************************** +!use module_zero_plumegen_coms +! +implicit none +type(plumegen_coms), pointer :: coms + +real(kind=kind_phys), PARAMETER :: FRC = 332.27, TMELT = 273., F0 = 0.75 !ice velocity factor +real(kind=kind_phys) DTMELT +! + DTMELT = 0. !conversion,ice to rain +! +!selection rules +IF (COMS%QI (COMS%L) .LE. 0.0 ) RETURN +IF (COMS%T (COMS%L) .LT. TMELT) RETURN +! + !OT(23,24) + DTMELT = COMS%DT * (2.27 / COMS%RHO (COMS%L) ) * COMS%CVI(COMS%L) * (COMS%T (COMS%L) - TMELT) * ( (COMS%RHO(COMS%L) & + * COMS%QI (COMS%L) * 1.E-6) **0.525) * (F0** ( - 0.42) ) + !after Mason,1956 +! +! check the possibilities +! +IF (DTMELT.LT.COMS%QI (COMS%L) ) THEN +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + DTMELT + COMS%QI (COMS%L) = COMS%QI (COMS%L) - DTMELT + COMS%T (COMS%L) = COMS%T (COMS%L) - FRC * DTMELT !cools air + + RETURN +! +ELSE +! + COMS%QH (COMS%L) = COMS%QH (COMS%L) + COMS%QI (COMS%L) !get all there is to get + COMS%T (COMS%L) = COMS%T (COMS%L) - FRC * COMS%QI (COMS%L) + COMS%QI (COMS%L) = 0.0 +! +ENDIF +! +RETURN +! +END SUBROUTINE MELT + +SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) + IMPLICIT NONE + INTEGER, INTENT(IN ) :: nzz1 + INTEGER, INTENT(IN ) :: nzz2 + REAL(kind=kind_phys), INTENT(IN ) :: vctra(nzz1) + REAL(kind=kind_phys), INTENT(OUT) :: vctrb(nzz2) + REAL(kind=kind_phys), INTENT(IN ) :: eleva(nzz1) + REAL(kind=kind_phys), INTENT(IN ) :: elevb(nzz2) + + INTEGER :: l + INTEGER :: k + INTEGER :: kk + REAL(kind=kind_phys) :: wt + + l=1 + + DO k=1,nzz2 + DO + IF ( (elevb(k) < eleva(1)) .OR. & + ((elevb(k) >= eleva(l)) .AND. (elevb(k) <= eleva(l+1))) ) THEN + wt = (elevb(k)-eleva(l))/(eleva(l+1)-eleva(l)) + vctrb(k) = vctra(l)+(vctra(l+1)-vctra(l))*wt + EXIT + ELSE IF ( elevb(k) > eleva(nzz1)) THEN + wt = (elevb(k)-eleva(nzz1))/(eleva(nzz1-1)-eleva(nzz1)) + vctrb(k) = vctra(nzz1)+(vctra(nzz1-1)-vctra(nzz1))*wt + EXIT + END IF + + l=l+1 + IF(l == nzz1) THEN + PRINT *,'htint:nzz1',nzz1 + DO kk=1,l + PRINT*,'kk,eleva(kk),elevb(kk)',kk,eleva(kk),elevb(kk) + END DO + STOP 'htint' + END IF + END DO + END DO +END SUBROUTINE htint +!----------------------------------------------------------------------------- +FUNCTION ESAT_PR (TEM) +! +! ******* Vapor Pressure A.L. Buck JAM V.20 p.1527. (1981) *********** +! +real(kind=kind_phys), PARAMETER :: CI1 = 6.1115, CI2 = 22.542, CI3 = 273.48 +real(kind=kind_phys), PARAMETER :: CW1 = 6.1121, CW2 = 18.729, CW3 = 257.87, CW4 = 227.3 +real(kind=kind_phys), PARAMETER :: TMELT = 273.3 + +real(kind=kind_phys) ESAT_PR +real(kind=kind_phys) temc , tem,esatm +! +! formulae from Buck, A.L., JAM 20,1527-1532 +! custom takes esat wrt water always. formula for h2o only +! good to -40C so: +! +! +TEMC = TEM - TMELT +IF (TEMC.GT. - 40.0) GOTO 230 +ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars +ESAT_PR = ESATM / 10. !kPa + +RETURN +! +230 ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) + +ESAT_PR = ESATM / 10. !kPa +RETURN +END function ESAT_PR +! ****************************************************************** + +! ------------------------------------------------------------------------ +END Module module_smoke_plumerise diff --git a/smoke/module_zero_plumegen_coms.F90 b/smoke/module_zero_plumegen_coms.F90 new file mode 100755 index 000000000..d00554753 --- /dev/null +++ b/smoke/module_zero_plumegen_coms.F90 @@ -0,0 +1,192 @@ +module module_zero_plumegen_coms + + use machine , only : kind_phys + + implicit none + integer, parameter :: nkp = 200, ntime = 200 + + type plumegen_coms + real(kind=kind_phys),dimension(nkp) :: w,t,qv,qc,qh,qi,sc, & ! blob + vth,vti,rho,txs, & + est,qsat! never used: ,qpas,qtotal + + real(kind=kind_phys),dimension(nkp) :: wc,wt,tt,qvt,qct,qht,qit,sct + real(kind=kind_phys),dimension(nkp) :: dzm,dzt,zm,zt,vctr1,vctr2 & + ,vt3dc,vt3df,vt3dk,vt3dg,scr1 + + real(kind=kind_phys),dimension(nkp) :: pke,the,thve,thee,pe,te,qvenv,dne ! environment at plume grid ! never used: rhe, sce + real(kind=kind_phys),dimension(nkp) :: ucon,vcon,thtcon ,rvcon,picon,tmpcon & ! never used: wcon, dncon, prcon + ,zcon,zzcon ! environment at RAMS grid ! never used: scon + + real(kind=kind_phys) :: DZ,DQSDZ,VISC(nkp),VISCOSITY,TSTPF + integer :: N,NM1,L + ! + real(kind=kind_phys) :: CVH(nkp),CVI(nkp),ADIABAT,& + WBAR,VHREL,VIREL ! advection + ! Never used: ADVW,ADVT,ADVV,ADVC,ADVH,ADVI,ALAST(10) + + ! + real(kind=kind_phys) :: ZSURF,ZTOP ! never used: ZBASE + ! never used: integer :: LBASE + ! + real(kind=kind_phys) :: AREA,RSURF,ALPHA,RADIUS(nkp) ! entrain + ! + real(kind=kind_phys) :: HEATING(ntime),FMOIST,BLOAD ! heating + ! + real(kind=kind_phys) :: DT,TIME,TDUR + integer :: MINTIME,MDUR,MAXTIME + ! + !REAL(kind=kind_phys),DIMENSION(nkp,2) :: W_VMD,VMD + REAL(kind=kind_phys) :: upe (nkp) + REAL(kind=kind_phys) :: vpe (nkp) + REAL(kind=kind_phys) :: vel_e (nkp) + + REAL(kind=kind_phys) :: vel_p (nkp) + REAL(kind=kind_phys) :: rad_p (nkp) + REAL(kind=kind_phys) :: vel_t (nkp) + REAL(kind=kind_phys) :: rad_t (nkp) + + REAL(kind=kind_phys) :: ztop_(ntime) + integer :: testval + contains + procedure :: set_to_zero => plumegen_coms_zero + end type plumegen_coms + + interface plumegen_coms + procedure :: plumegen_coms_constructor + end interface plumegen_coms + + type(plumegen_coms), private, target :: private_thread_coms + logical, private :: mzpc_initialized = .false. + +!$OMP THREADPRIVATE(private_thread_coms) +!$OMP THREADPRIVATE(mzpc_initialized) + +contains + + function get_thread_coms() result(coms) + implicit none + class(plumegen_coms), pointer :: coms + if(.not.mzpc_initialized) then + private_thread_coms = plumegen_coms() + mzpc_initialized = .true. + endif + coms => private_thread_coms + end function get_thread_coms + + type(plumegen_coms) function plumegen_coms_constructor() result(this) + implicit none + call plumegen_coms_zero(this) + this%testval=3314 + end function plumegen_coms_constructor + + subroutine plumegen_coms_zero(this) + implicit none + class(plumegen_coms) :: this + + this%w=0.0 + this%t=0.0 + this%qv=0.0 + this%qc=0.0 + this%qh=0.0 + this%qi=0.0 + this%sc=0.0 + this%vth=0.0 + this%vti=0.0 + this%rho=0.0 + this%txs=0.0 + this%est=0.0 + this%qsat=0.0 + !this%qpas=0.0 + !this%qtotal=0.0 + this%wc=0.0 + this%wt=0.0 + this%tt=0.0 + this%qvt=0.0 + this%qct=0.0 + this%qht=0.0 + this%qit=0.0 + this%sct=0.0 + this%dzm=0.0 + this%dzt=0.0 + this%zm=0.0 + this%zt=0.0 + this%vctr1=0.0 + this%vctr2=0.0 + this%vt3dc=0.0 + this%vt3df=0.0 + this%vt3dk=0.0 + this%vt3dg=0.0 + this%scr1=0.0 + this%pke=0.0 + this%the=0.0 + this%thve=0.0 + this%thee=0.0 + this%pe=0.0 + this%te=0.0 + this%qvenv=0.0 + !this%rhe=0.0 + this%dne=0.0 + !this%sce=0.0 + this%ucon=0.0 + this%vcon=0.0 + !this%wcon=0.0 + this%thtcon =0.0 + this%rvcon=0.0 + this%picon=0.0 + this%tmpcon=0.0 + !this%dncon=0.0 + !this%prcon=0.0 + this%zcon=0.0 + this%zzcon=0.0 + !this%scon=0.0 + this%dz=0.0 + this%dqsdz=0.0 + this%visc=0.0 + this%viscosity=0.0 + this%tstpf=0.0 + !this%advw=0.0 + !this%advt=0.0 + !this%advv=0.0 + !this%advc=0.0 + !this%advh=0.0 + !this%advi=0.0 + this%cvh=0.0 + this%cvi=0.0 + this%adiabat=0.0 + this%wbar=0.0 + !this%alast=0.0 + this%vhrel=0.0 + this%virel=0.0 + this%zsurf=0.0 + !this%zbase=0.0 + this%ztop=0.0 + this%area=0.0 + this%rsurf=0.0 + this%alpha=0.0 + this%radius=0.0 + this%heating=0.0 + this%fmoist=0.0 + this%bload=0.0 + this%dt=0.0 + this%time=0.0 + this%tdur=0.0 + this%ztop_=0.0 + this%upe =0.0 + this%vpe =0.0 + this%vel_e =0.0 + this%vel_p =0.0 + this%rad_p =0.0 + this%vel_t =0.0 + this%rad_t =0.0 + !this%W_VMD=0.0 + !this%VMD=0.0 + this%n=0 + this%nm1=0 + this%l=0 + !this%lbase=0 + this%mintime=0 + this%mdur=0 + this%maxtime=0 + end subroutine plumegen_coms_zero +end module module_zero_plumegen_coms diff --git a/smoke/plume_data_mod.F90 b/smoke/plume_data_mod.F90 new file mode 100755 index 000000000..ce89dc4fd --- /dev/null +++ b/smoke/plume_data_mod.F90 @@ -0,0 +1,49 @@ +module plume_data_mod + + use machine , only : kind_phys + + implicit none + + ! -- FRP parameters + integer, dimension(0:20), parameter :: & + catb = (/ & + 0, & + 2, 1, 2, 1, & !floresta tropical 2 and 4 / extra trop fores 1,3,5 + 2, 3, 3, 3, 3, & !cerrado/woody savanna :6 a 9 + 4, 4, 4, 4, 4, 0, 4, 0, 0, 0, 0 & !pastagem/lavouras: 10 ... + /) + + real(kind=kind_phys), dimension(0:4), parameter :: & + flaming = (/ & + 0.00, & ! + 0.45, & ! % biomass burned at flaming phase : tropical forest igbp 2 and 4 + 0.45, & ! % biomass burned at flaming phase : extratropical forest igbp 1 , 3 and 5 + 0.75, & ! % biomass burned at flaming phase : cerrado/woody savanna igbp 6 to 9 + 0.00 & ! % biomass burned at flaming phase : pastagem/lavoura: igbp 10 a 17 + /) + + real(kind=kind_phys), dimension(0:20), parameter :: & + msize= (/ & + 0.00021, & !0near water,1Evergreen needleleaf,2EvergreenBroadleaf,!3Deciduous Needleleaf,4Deciduous Broadleaf + 0.00021, 0.00021, 0.00021, 0.00021, & !5Mixed forest,6Closed shrublands,7Open shrublands,8Woody savannas,9Savannas, + 0.00023, 0.00022, 0.00022, 0.00022, 0.00029, &! 10Grassland,11Permanent wetlands,12cropland,13'Urban and Built-Up' + 0.00029, 0.00021, 0.00026, 0.00021, 0.00026, &!14cropland/natural vegetation mosaic,15Snow and ice,16Barren or sparsely vegetated + 0.00021, 0.00021, 0.00021, 0.00021, 0.00021, 0.00021 & !17Water,18Wooded Tundra,19Mixed Tundra,20Bare Ground Tundra + /) + + ! -- FRP buffer indices + integer, parameter :: p_frp_hr = 1 + integer, parameter :: p_frp_std = 2 + integer, parameter :: num_frp_plume = 2 + + ! -- plumerise parameters + integer, parameter :: tropical_forest = 1 + integer, parameter :: boreal_forest = 2 + integer, parameter :: savannah = 3 + integer, parameter :: grassland = 4 + integer, parameter :: nveg_agreg = 4 + integer, parameter :: wind_eff = 1 + + public + +end module plume_data_mod diff --git a/smoke/readme b/smoke/readme deleted file mode 100644 index e8027d7fa..000000000 --- a/smoke/readme +++ /dev/null @@ -1 +0,0 @@ -the smoke directory diff --git a/smoke/rrfs_smoke_config.F90 b/smoke/rrfs_smoke_config.F90 new file mode 100755 index 000000000..f3cdd13c9 --- /dev/null +++ b/smoke/rrfs_smoke_config.F90 @@ -0,0 +1,125 @@ +! +! Haiqin.Li@noaa.gov +! 06/2021 +! constant parameters and chemistry configurations and tracers +! (This will be splited into three subroutine for configuration, constant and tracers later) +! 06/2021 move configuration into chem nml +! +module rrfs_smoke_config + + use machine , only : kind_phys + + implicit none + + !-- constant paramters + real(kind=kind_phys), parameter :: epsilc = 1.e-12 + + !-- chemistyr module configurations + integer :: chem_opt = 1 + integer :: kemit = 1 + integer :: dust_opt = 5 + integer :: dmsemis_opt = 1 + integer :: seas_opt = 2 + integer :: biomass_burn_opt=1 + logical :: do_plumerise = .true. + integer :: addsmoke_flag = 1 + integer :: plumerisefire_frq=60 ! Let's add to the namelist + integer :: chem_conv_tr = 0 + integer :: aer_ra_feedback=1 !0 + integer :: aer_ra_frq = 60 + integer :: wetdep_ls_opt = 1 + integer :: drydep_opt = 1 + logical :: bb_dcycle = .false. + logical :: smoke_forecast = .false. + logical :: aero_ind_fdb = .false. + logical :: dbg_opt = .true. + + real(kind=kind_phys), parameter :: depo_fact=0. + integer, parameter :: CHEM_OPT_GOCART= 1 + INTEGER, PARAMETER :: gocartracm_kpp = 301 + integer, parameter :: chem_tune_tracers = 20 + integer, parameter :: DUST_OPT_NONE = 0 + integer, parameter :: SEAS_OPT_NONE = 0 + ! -- DMS emissions + integer, parameter :: DMSE_OPT_NONE = 0 + integer, parameter :: DMSE_OPT_ENABLE = 1 + ! -- subgrid convective transport + integer, parameter :: CTRA_OPT_NONE = 0 + integer, parameter :: CTRA_OPT_GRELL = 2 + ! -- large scale wet deposition + integer, parameter :: WDLS_OPT_NONE = 0 + integer, parameter :: WDLS_OPT_GSD = 1 + integer, parameter :: WDLS_OPT_NGAC = 2 + + ! -- + integer, parameter :: call_chemistry = 1 + integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 + integer, parameter :: num_emis_ant = 7 + + integer, parameter :: SEAS_OPT_DEFAULT = 1 + + integer, parameter :: DUST_OPT_GOCART = 1 + integer, parameter :: DUST_OPT_AFWA = 3 + integer, parameter :: DUST_OPT_FENGSHA = 5 + + ! -- biomass burning emissions + integer, parameter :: BURN_OPT_ENABLE = 1 + integer, parameter :: FIRE_OPT_MODIS = 1 + integer, parameter :: FIRE_OPT_GBBEPx = 2 + + ! -- hydrometeors + integer, parameter :: p_qv=1 + integer, parameter :: p_qc=2 + integer, parameter :: p_qi=3 + ! -- set pointers to predefined atmospheric tracers + ! -- FV3 GFDL microphysics + integer, parameter :: p_atm_shum = 1 + integer, parameter :: p_atm_cldq = 2 + integer, parameter :: p_atm_o3mr = 7 + + integer :: numgas = 0 + + real(kind=kind_phys) :: wetdep_ls_alpha(chem_tune_tracers)=-999. + + !-- tracers + integer, parameter :: p_so2=1 + integer, parameter :: p_sulf=2 + integer, parameter :: p_dms=3 + integer, parameter :: p_msa=4 + integer, parameter :: p_p25=5, p_smoke=5 + integer, parameter :: p_bc1=6 + integer, parameter :: p_bc2=7 + integer, parameter :: p_oc1=8 + integer, parameter :: p_oc2=9 + integer, parameter :: p_dust_1=10 + integer, parameter :: p_dust_2=11 + integer, parameter :: p_dust_3=12 + integer, parameter :: p_dust_4=13 + integer, parameter :: p_dust_5=14 + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 + integer, parameter :: p_p10 =20 + + integer, parameter :: p_edust1=1,p_edust2=2,p_edust3=3,p_edust4=4,p_edust5=5 + integer, parameter :: p_eseas1=1,p_eseas2=2,p_eseas3=3,p_eseas4=4,p_eseas5=5 + + integer :: p_ho=0,p_h2o2=0,p_no3=0 + + ! constants + real(kind=kind_phys), PARAMETER :: airmw = 28.97 + real(kind=kind_phys), PARAMETER :: mw_so2_aer = 64.066 + real(kind=kind_phys), PARAMETER :: mw_so4_aer = 96.066 + real(kind=kind_phys), parameter :: smw = 32.00 + real(kind=kind_phys), parameter :: mwdry = 28. +! d is the molecular weight of dry air (28.966), w/d = 0.62197, and +! (d - w)/d = 0.37803 +! http://atmos.nmsu.edu/education_and_outreach/encyclopedia/humidity.htm + + ! -- fire options +! integer, parameter :: num_plume_data = 1 + + +end module diff --git a/smoke/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 new file mode 100755 index 000000000..b5dbf5199 --- /dev/null +++ b/smoke/rrfs_smoke_data.F90 @@ -0,0 +1,644 @@ +module rrfs_smoke_data + use machine , only : kind_phys + implicit none + INTEGER, PARAMETER :: dep_seasons = 5 + INTEGER, PARAMETER :: nlu = 25 + + type wesely_pft + integer :: npft + integer :: months + INTEGER, pointer :: seasonal_wes(:,:,:,:) => NULL() + contains + final :: wesely_pft_destructor + end type wesely_pft + + interface wesely_pft + procedure :: wesely_pft_constructor + end interface wesely_pft + +!-------------------------------------------------- +! many of these parameters will depend on the RADM mechanism! +! if you change it, lets talk about it and get it done!!! +!-------------------------------------------------- + + REAL(kind_phys), parameter :: small_value = 1.e-36 + REAL(kind_phys), parameter :: large_value = 1.e36 + +!-------------------------------------------------- +! following currently hardwired to USGS +!-------------------------------------------------- + integer, parameter :: isice_temp = 24 + integer, parameter :: iswater_temp = 16 + integer, parameter :: wrf2mz_lt_map(nlu) = (/ 1, 2, 2, 2, 2, & + 4, 3, 3, 3, 3, & + 4, 5, 4, 5, 6, & + 7, 9, 6, 8, 9, & + 6, 6, 8, 0, 0 /) + real(kind_phys), parameter :: wh2o = 18.0153 + real(kind_phys), parameter :: wpan = 121.04793 + real(kind_phys), PARAMETER :: KARMAN=0.4 + INTEGER, parameter :: luse2usgs(21) = (/14,13,12,11,15,8,9,10,10,7, & + 17,4,1,5,24,19,16,21,22,23,16 /) + character(len=4), parameter :: mminlu = 'USGS' + + ! integer, parameter :: pan_seasons = 5 + ! integer, parameter :: pan_lands = 11 + + type smoke_data + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Taken from dep_simple_mod + INTEGER :: ixxxlu(nlu) + REAL(KIND_PHYS) :: kpart(nlu) + REAL(KIND_PHYS) :: rac(nlu,dep_seasons), rclo(nlu,dep_seasons), rcls(nlu,dep_seasons) + REAL(KIND_PHYS) :: rgso(nlu,dep_seasons), rgss(nlu,dep_seasons) + REAL(KIND_PHYS) :: ri(nlu,dep_seasons), rlu(nlu,dep_seasons) + ! REAL(KIND_PHYS) :: ri_pan(pan_seasons,pan_lands) + ! never used: real(kind_phys) :: c0_pan(pan_lands) + ! never used: real(kind_phys) :: k_pan (pan_lands) + + ! never used: integer :: month + REAL(KIND_PHYS) :: dratio(1000), hstar(1000), hstar4(1000) + REAL(KIND_PHYS) :: f0(1000), dhr(1000), scpr23(1000) + + ! Note: scpr23 is only read, never written + + ! never used: type(wesely_pft) :: seasonal_pft + + ! never used: logical, pointer :: is_aerosol(:) => NULL() + + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Taken from dep_wet_ls_mod + real(kind_phys), dimension(:), pointer :: alpha => NULL() + contains + final :: smoke_data_destructor + procedure :: dep_init + end type smoke_data + + interface smoke_data + procedure :: smoke_data_constructor + end interface smoke_data + + type(smoke_data), target, private :: private_thread_data + logical, private :: rrfs_smoke_data_initialized = .false. + + !$OMP THREADPRIVATE(private_thread_data) + !$OMP THREADPRIVATE(rrfs_smoke_data_initialized) + +contains + + function get_thread_smoke_data() result(data) + implicit none + class(smoke_data), pointer :: data + if(.not. rrfs_smoke_data_initialized) then + private_thread_data = smoke_data() + rrfs_smoke_data_initialized = .true. + endif + data => private_thread_data + end function get_thread_smoke_data + + subroutine wesely_pft_destructor(this) + implicit none + type(wesely_pft) :: this + if(associated(this%seasonal_wes)) then + deallocate(this%seasonal_wes) + nullify(this%seasonal_wes) + endif + end subroutine wesely_pft_destructor + + function wesely_pft_constructor() result(this) + implicit none + class(wesely_pft), pointer :: this + nullify(this%seasonal_wes) + end function wesely_pft_constructor + + function smoke_data_constructor() result(this) + implicit none + type(smoke_data) :: this + ! These are never used: + ! this%c0_pan = (/ 0.000, 0.006, 0.002, 0.009, 0.015, & + ! 0.006, 0.000, 0.000, 0.000, 0.002, 0.002 /) + ! this%k_pan = (/ 0.000, 0.010, 0.005, 0.004, 0.003, & + ! 0.005, 0.000, 0.000, 0.000, 0.075, 0.002 /) + ! this%month = 0 + ! this%seasonal_pft = wesely_pft() + ! nullify(this%is_aerosol) + nullify(this%alpha) + ! This is not called in the original non-thread-safe code: + ! call this%dep_init() + end function smoke_data_constructor + + subroutine smoke_data_destructor(this) + implicit none + type(smoke_data) :: this + if(associated(this%alpha)) then + deallocate(this%alpha) + nullify(this%alpha) + endif + ! Never used: + ! if(associated(this%is_aerosol)) then + ! deallocate(this%is_aerosol) + ! nullify(this%is_aerosolo) + ! endif + end subroutine smoke_data_destructor + + +! SUBROUTINE dep_init( id, numgas, mminlu_loc, & +! ips, ipe, jps, jpe, ide, jde ) + SUBROUTINE dep_init(this) + ! Lifted out of dep_simple_mod, this initializes + ! member variables that were module variables in + ! that module. +!-- + implicit none + class(smoke_data) :: this + +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + ! Unused: + ! integer, intent(in) :: numgas + ! integer, intent(in) :: ips, ipe, jps, jpe + ! integer, intent(in) :: ide, jde + ! mmin_lu_loc had no definition, but is also unused + +!-------------------------------------------------- +! .. Local Scalars +!-------------------------------------------------- + INTEGER :: iland, iseason, l + integer :: iprt + integer :: astat + integer :: ncid + integer :: dimid + integer :: varid + integer :: cpos, slen + integer :: lon_e, lat_e + integer :: iend, jend + integer :: chem_opt + integer, allocatable :: input_wes_seasonal(:,:,:,:) + REAL(KIND_PHYS) :: sc + character(len=128) :: err_msg + character(len=128) :: filename + character(len=3) :: id_num +!-------------------------------------------------- +! .. Local Arrays +!-------------------------------------------------- + REAL(KIND_PHYS) :: dat1(nlu,dep_seasons), dat2(nlu,dep_seasons), & + dat3(nlu,dep_seasons), dat4(nlu,dep_seasons), & + dat5(nlu,dep_seasons), dat6(nlu,dep_seasons), & + dat7(nlu,dep_seasons) + ! REAL(KIND_PHYS) :: dat8(pan_seasons,pan_lands) + chem_opt = chem_opt + +!-------------------------------------------------- +! .. Data Statements .. +! THIS%RI for stomatal resistance +! data ((this%ri(ILAND,ISEASON),ILAND=1,nlu),ISEASON=1,dep_seasons)/0.10E+11, & + DATA ((dat1(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.60E+02, 0.60E+02, 0.60E+02, 0.60E+02, 0.70E+02, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.12E+03, 0.70E+02, 0.13E+03, 0.70E+02, & + 0.13E+03, 0.10E+03, 0.10E+11, 0.80E+02, 0.10E+03, 0.10E+11, & + 0.80E+02, 0.10E+03, 0.10E+03, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, 0.10E+11, & + 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, & + 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, & + 0.10E+11, 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.70E+02, 0.40E+03, 0.80E+03, 0.10E+11, & + 0.10E+11, 0.80E+03, 0.10E+11, 0.10E+11, 0.80E+03, 0.80E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.14E+03, 0.24E+03, 0.24E+03, 0.24E+03, & + 0.12E+03, 0.14E+03, 0.25E+03, 0.70E+02, 0.25E+03, 0.19E+03, & + 0.10E+11, 0.16E+03, 0.19E+03, 0.10E+11, 0.16E+03, 0.19E+03, & + 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ +! .. + IF (nlu/=25) THEN + write(0,*) 'number of land use classifications not correct ' + stop + END IF + IF (dep_seasons/=5) THEN + write(0,*) 'number of dep_seasons not correct ' + stop + END IF + +! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF +! M. L. WESELY, ATMOSPHERIC ENVIRONMENT 23 (1989) 1293-1304 + +! Seasonal categories: +! 1: midsummer with lush vegetation +! 2: autumn with unharvested cropland +! 3: late autumn with frost, no snow +! 4: winter, snow on ground and subfreezing +! 5: transitional spring with partially green short annuals + +! Land use types: +! USGS type Wesely type +! 1: Urban and built-up land 1 +! 2: Dryland cropland and pasture 2 +! 3: Irrigated cropland and pasture 2 +! 4: Mix. dry/irrg. cropland and pasture 2 +! 5: Cropland/grassland mosaic 2 +! 6: Cropland/woodland mosaic 4 +! 7: Grassland 3 +! 8: Shrubland 3 +! 9: Mixed shrubland/grassland 3 +! 10: Savanna 3, always summer +! 11: Deciduous broadleaf forest 4 +! 12: Deciduous needleleaf forest 5, autumn and winter modi +! 13: Evergreen broadleaf forest 4, always summer +! 14: Evergreen needleleaf forest 5 +! 15: Mixed Forest 6 +! 16: Water Bodies 7 +! 17: Herbaceous wetland 9 +! 18: Wooded wetland 6 +! 19: Barren or sparsely vegetated 8 +! 20: Herbaceous Tundra 9 +! 21: Wooded Tundra 6 +! 22: Mixed Tundra 6 +! 23: Bare Ground Tundra 8 +! 24: Snow or Ice -, always winter +! 25: No data 8 + + +! Order of data: +! | +! | seasonal category +! \|/ +! ---> landuse type +! 1 2 3 4 5 6 7 8 9 +! THIS%RLU for outer surfaces in the upper canopy + DO iseason = 1, dep_seasons + this%ri(1:nlu,iseason) = dat1(1:nlu,iseason) + END DO +! data ((this%rlu(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat2(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, & + 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, & + 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.20E+04, 0.60E+04, 0.90E+04, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + this%rlu(1:nlu,iseason) = dat2(1:nlu,iseason) + END DO +! THIS%RAC for transfer that depends on canopy height and density +! data ((this%rac(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+03, & + DATA ((dat3(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+04, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.00E+00, 0.30E+03, 0.20E+04, 0.00E+00, & + 0.30E+03, 0.20E+04, 0.20E+04, 0.00E+00, 0.00E+00, 0.00E+00, & + 0.10E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+04, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.15E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.17E+04, 0.00E+00, 0.20E+03, 0.17E+04, & + 0.00E+00, 0.20E+03, 0.17E+04, 0.17E+04, 0.00E+00, 0.00E+00, & + 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, 0.10E+03, & + 0.15E+04, 0.00E+00, 0.10E+03, 0.15E+04, 0.15E+04, 0.00E+00, & + 0.00E+00, 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+02, 0.10E+04, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, & + 0.50E+02, 0.15E+04, 0.00E+00, 0.50E+02, 0.15E+04, 0.15E+04, & + 0.00E+00, 0.00E+00, 0.00E+00, 0.10E+03, 0.50E+02, 0.50E+02, & + 0.50E+02, 0.50E+02, 0.12E+04, 0.80E+02, 0.80E+02, 0.80E+02, & + 0.10E+03, 0.12E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, & + 0.00E+00, 0.20E+03, 0.15E+04, 0.00E+00, 0.20E+03, 0.15E+04, & + 0.15E+04, 0.00E+00, 0.00E+00, 0.00E+00/ + DO iseason = 1, dep_seasons + this%rac(1:nlu,iseason) = dat3(1:nlu,iseason) + END DO +! THIS%RGSS for ground surface SO2 +! data ((this%rgss(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.40E+03, & + DATA ((dat4(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.40E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, 0.10E+04, & + 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+04, & + 0.40E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.50E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, & + 0.10E+04, 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, & + 0.10E+04, 0.40E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, 0.10E+01, 0.10E+01, & + 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, 0.20E+03, 0.10E+04, & + 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.50E+03, 0.10E+03, 0.10E+03, 0.10E+01, & + 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+04, 0.10E+03, 0.10E+04, 0.50E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, & + 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, & + 0.10E+01, 0.10E+01, 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, & + 0.20E+03, 0.10E+04, 0.10E+03, 0.10E+04/ + DO iseason = 1, dep_seasons + this%rgss(1:nlu,iseason) = dat4(1:nlu,iseason) + END DO +! THIS%RGSO for ground surface O3 +! data ((this%rgso(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.30E+03, & + DATA ((dat5(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.30E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, & + 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03, & + 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.80E+03, 0.30E+03, & + 0.40E+03, 0.80E+03, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, & + 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, & + 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, & + 0.35E+04, 0.40E+03, 0.60E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.20E+03, 0.35E+04, 0.35E+04, 0.20E+04, & + 0.35E+04, 0.35E+04, 0.40E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.40E+03, 0.35E+04, 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, & + 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, & + 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03/ + DO iseason = 1, dep_seasons + this%rgso(1:nlu,iseason) = dat5(1:nlu,iseason) + END DO +! THIS%RCLS for exposed surfaces in the lower canopy SO2 +! data ((this%rcls(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat6(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.20E+04, 0.40E+04, 0.10E+11, 0.90E+04, 0.40E+04, & + 0.10E+11, 0.90E+04, 0.40E+04, 0.40E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.30E+04, 0.60E+04, 0.10E+11, 0.90E+04, & + 0.60E+04, 0.10E+11, 0.90E+04, 0.60E+04, 0.60E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.20E+04, 0.20E+03, 0.40E+03, 0.10E+11, & + 0.90E+04, 0.40E+03, 0.10E+11, 0.90E+04, 0.40E+03, 0.40E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + this%rcls(1:nlu,iseason) = dat6(1:nlu,iseason) + END DO +! THIS%RCLO for exposed surfaces in the lower canopy O3 +! data ((this%rclo(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat7(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, 0.40E+03, & + 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.40E+03, 0.60E+03, & + 0.10E+11, 0.40E+03, 0.60E+03, 0.60E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, & + 0.40E+03, 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.80E+03, & + 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.40E+03, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.10E+04, 0.15E+04, 0.60E+03, 0.10E+11, & + 0.80E+03, 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.10E+04, 0.50E+03, 0.15E+04, 0.10E+04, 0.15E+04, 0.70E+03, & + 0.10E+11, 0.60E+03, 0.70E+03, 0.10E+11, 0.60E+03, 0.70E+03, & + 0.70E+03, 0.10E+11, 0.10E+11, 0.10E+11/ + + DO iseason = 1, dep_seasons + this%rclo(1:nlu,iseason) = dat7(1:nlu,iseason) + END DO + + ! data ((dat8(iseason,iland),iseason=1,pan_seasons),iland=1,pan_lands) / & + ! 1.e36, 60., 120., 70., 130., 100.,1.e36,1.e36, 80., 100., 150., & + ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36,1.e36,1.e36,1.e36, 400., 800.,1.e36,1.e36,1.e36,1.e36,1.e36, & + ! 1.e36, 120., 240., 140., 250., 190.,1.e36,1.e36, 160., 200., 300. / + ! this%ri_pan(:,:) = dat8(:,:) + +!-------------------------------------------------- +! Initialize parameters +!-------------------------------------------------- + this%hstar = 0. + this%hstar4 = 0. + this%dhr = 0. + this%f0 = 0. + this%dratio = 1.0 ! FIXME: IS THIS RIGHT? + this%scpr23 = 1.0 ! FIXME: IS THIS RIGHT? + +!-------------------------------------------------- +! HENRY''S LAW COEFFICIENTS +! Effective Henry''s law coefficient at pH 7 +! [KH298]=mole/(l atm) +!-------------------------------------------------- + +! DATA FOR AEROSOL PARTICLE DEPOSITION FOR THE MODEL OF +! J. W. ERISMAN, A. VAN PUL AND P. WYERS +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 + +! vd = (u* / k) * CORRECTION FACTORS + +! CONSTANT K FOR LANDUSE TYPES: +! urban and built-up land + this%kpart(1) = 500. +! dryland cropland and pasture + this%kpart(2) = 500. +! irrigated cropland and pasture + this%kpart(3) = 500. +! mixed dryland/irrigated cropland and past + this%kpart(4) = 500. +! cropland/grassland mosaic + this%kpart(5) = 500. +! cropland/woodland mosaic + this%kpart(6) = 100. +! grassland + this%kpart(7) = 500. +! shrubland + this%kpart(8) = 500. +! mixed shrubland/grassland + this%kpart(9) = 500. +! savanna + this%kpart(10) = 500. +! deciduous broadleaf forest + this%kpart(11) = 100. +! deciduous needleleaf forest + this%kpart(12) = 100. +! evergreen broadleaf forest + this%kpart(13) = 100. +! evergreen needleleaf forest + this%kpart(14) = 100. +! mixed forest + this%kpart(15) = 100. +! water bodies + this%kpart(16) = 500. +! herbaceous wetland + this%kpart(17) = 500. +! wooded wetland + this%kpart(18) = 500. +! barren or sparsely vegetated + this%kpart(19) = 500. +! herbaceous tundra + this%kpart(20) = 500. +! wooded tundra + this%kpart(21) = 100. +! mixed tundra + this%kpart(22) = 500. +! bare ground tundra + this%kpart(23) = 500. +! snow or ice + this%kpart(24) = 500. +! Comments: + this%kpart(25) = 500. +! Erisman et al. (1994) give +! k = 500 for low vegetation and k = 100 for forests. + +! For desert k = 500 is taken according to measurements +! on bare soil by +! J. Fontan, A. Lopez, E. Lamaud and A. Druilhet (1997) +! Vertical Flux Measurements of the Submicronic Aerosol Particles +! and Parametrisation of the Dry Deposition Velocity +! in: Biosphere-Atmosphere Exchange of Pollutants +! and Trace Substances +! Editor: S. Slanina. Springer-Verlag Berlin, Heidelberg, 1997 +! pp. 381-390 + +! For coniferous forest the Erisman value of k = 100 is taken. +! Measurements of Erisman et al. (1997) in a coniferous forest +! in the Netherlands, lead to values of k between 20 and 38 +! (Atmospheric Environment 31 (1997), 321-332). +! However, these high values of vd may be reached during +! instable cases. The eddy correlation measurements +! of Gallagher et al. (1997) made during the same experiment +! show for stable cases (L>0) values of k between 200 and 250 +! at minimum (Atmospheric Environment 31 (1997), 359-373). +! Fontan et al. (1997) found k = 250 in a forest +! of maritime pine in southwestern France. + +! For gras, model calculations of Davidson et al. support +! the value of 500. +! C. I. Davidson, J. M. Miller and M. A. Pleskov +! The Influence of Surface Structure on Predicted Particles +! Dry Deposition to Natural Gras Canopies +! Water, Air, and Soil Pollution 18 (1982) 25-43 + +! Snow covered surface: The experiment of Ibrahim et al. (1983) +! gives k = 436 for 0.7 um diameter particles. +! The deposition velocity of Milford and Davidson (1987) +! gives k = 154 for continental sulfate aerosol. +! M. Ibrahim, L. A. Barrie and F. Fanaki +! Atmospheric Environment 17 (1983), 781-788 + +! J. B. Milford and C. I. Davidson +! The Sizes of Particulate Sulfate and Nitrate in the Atmosphere +! - A Review +! JAPCA 37 (1987), 125-134 +! no data +! WRITE (0,*) ' return from rcread ' +! ********************************************************* + +! Simplified landuse scheme for deposition and biogenic emission +! subroutines +! (ISWATER and ISICE are already defined elsewhere, +! therefore water and ice are not considered here) + +! 1 urban or bare soil +! 2 agricultural +! 3 grassland +! 4 deciduous forest +! 5 coniferous and mixed forest +! 6 other natural landuse categories + + + IF (mminlu=='OLD ') THEN + this%ixxxlu(1) = 1 + this%ixxxlu(2) = 2 + this%ixxxlu(3) = 3 + this%ixxxlu(4) = 4 + this%ixxxlu(5) = 5 + this%ixxxlu(6) = 5 + this%ixxxlu(7) = 0 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 1 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 0 + this%ixxxlu(12) = 4 + this%ixxxlu(13) = 6 + END IF + IF (mminlu=='USGS') THEN + this%ixxxlu(1) = 1 + this%ixxxlu(2) = 2 + this%ixxxlu(3) = 2 + this%ixxxlu(4) = 2 + this%ixxxlu(5) = 2 + this%ixxxlu(6) = 4 + this%ixxxlu(7) = 3 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 3 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 4 + this%ixxxlu(12) = 5 + this%ixxxlu(13) = 4 + this%ixxxlu(14) = 5 + this%ixxxlu(15) = 5 + this%ixxxlu(16) = 0 + this%ixxxlu(17) = 6 + this%ixxxlu(18) = 4 + this%ixxxlu(19) = 1 + this%ixxxlu(20) = 6 + this%ixxxlu(21) = 4 + this%ixxxlu(22) = 6 + this%ixxxlu(23) = 1 + this%ixxxlu(24) = 0 + this%ixxxlu(25) = 1 + END IF + IF (mminlu=='SiB ') THEN + this%ixxxlu(1) = 4 + this%ixxxlu(2) = 4 + this%ixxxlu(3) = 4 + this%ixxxlu(4) = 5 + this%ixxxlu(5) = 5 + this%ixxxlu(6) = 6 + this%ixxxlu(7) = 3 + this%ixxxlu(8) = 6 + this%ixxxlu(9) = 6 + this%ixxxlu(10) = 6 + this%ixxxlu(11) = 1 + this%ixxxlu(12) = 2 + this%ixxxlu(13) = 6 + this%ixxxlu(14) = 1 + this%ixxxlu(15) = 0 + this%ixxxlu(16) = 0 + this%ixxxlu(17) = 1 + END IF + + END SUBROUTINE dep_init +end module rrfs_smoke_data diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 new file mode 100644 index 000000000..8625fe844 --- /dev/null +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -0,0 +1,338 @@ +!>\file rrfs_smoke_lsdep_wrapper.F90 +!! This file is RRFS-smoke large-scale wet deposition wrapper with CCPP +!! Haiqin.Li@noaa.gov 04/2021 + + module rrfs_smoke_lsdep_wrapper + + use physcons, only : g => con_g, pi => con_pi + use machine , only : kind_phys + use rrfs_smoke_config + use dep_wet_ls_mod + use dust_data_mod + use rrfs_smoke_data + + implicit none + + private + + public :: rrfs_smoke_lsdep_wrapper_init, rrfs_smoke_lsdep_wrapper_run, rrfs_smoke_lsdep_wrapper_finalize + +contains + +!> \brief Brief description of the subroutine +!! + subroutine rrfs_smoke_lsdep_wrapper_init() + end subroutine rrfs_smoke_lsdep_wrapper_init + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_rrfs_smoke_lsdep_wrapper_finalize Argument Table +!! + subroutine rrfs_smoke_lsdep_wrapper_finalize() + end subroutine rrfs_smoke_lsdep_wrapper_finalize + +!> \defgroup gsd_chem_group GSD Chem driver Module +!! This is the gsd chemistry +!>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem driver Module +!! \section arg_table_rrfs_smoke_lsdep_wrapper_run Argument Table +!! \htmlinclude rrfs_smoke_lsdep_wrapper_run.html +!! +!>\section rrfs_smoke_lsdep_wrapper GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & + rain_cpl, rainc_cpl, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & + w, dqdt, ntrac,ntsmoke,ntdust, & + gq0,qgrs,wetdep_ls_opt_in, & + errmsg,errflg) + + implicit none + + + integer, intent(in) :: im,kte,kme,ktau + integer, intent(in) :: ntrac,ntsmoke,ntdust + real(kind_phys),intent(in) :: dt + + integer, parameter :: ids=1,jds=1,jde=1, kds=1 + integer, parameter :: ims=1,jms=1,jme=1, kms=1 + integer, parameter :: its=1,jts=1,jte=1, kts=1 + + real(kind_phys), dimension(im), intent(in) :: rain_cpl, rainc_cpl + real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + us3d, vs3d, spechum, w, dqdt + real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: gq0, qgrs + integer, intent(in) :: wetdep_ls_opt_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & + p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, dqdti + + real(kind_phys), dimension(ims:im, jms:jme) :: rcav, rnav + +!>- vapor & chemistry variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem + real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: var_rmv + + integer :: ide, ime, ite, kde + + real(kind_phys) :: dtstep + real(kind_phys), dimension(1:num_chem) :: ppm2ugkg + + type(smoke_data), pointer :: data + +!>-- local variables + integer :: i, j, jp, k, kp, n + + data=>get_thread_smoke_data() + + errmsg = '' + errflg = 0 + + wetdep_ls_opt = wetdep_ls_opt_in + !print*,'hli wetdep_ls_opt',wetdep_ls_opt + + ! -- set domain + ide=im + ime=im + ite=im + kde=kte + + ! -- volume to mass fraction conversion table (ppm -> ug/kg) + ppm2ugkg = 1._kind_phys + !ppm2ugkg(p_so2 ) = 1.e+03_kind_phys * mw_so2_aer / mwdry + ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + + ! -- initialize large-sacle wet depostion + if (ktau==1) then + call dep_wet_ls_init(data) + endif + + ! -- set control flags + + ! -- compute accumulated large-scale and convective rainfall since last call + if (ktau > 1) then + dtstep = call_chemistry * dt + else + dtstep = dt + end if + + ! -- compute incremental convective and large-scale rainfall + do i=its,ite + rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm + rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm + enddo + +!!! + +!>- get ready for chemistry run + call rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,dqdti,z_at_w,vvel, & + ntsmoke,ntdust, & + ntrac,gq0,num_chem, num_moist, & + ppm2ugkg,moist,chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + ! -- ls wet deposition + select case (wetdep_ls_opt) + case (WDLS_OPT_GSD) + call wetdep_ls(data,dt,chem,rnav,moist,rho_phy,var_rmv, & + num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + case (WDLS_OPT_NGAC) + call WetRemovalGOCART(data,its,ite, jts,jte, kts,kte, 1,1, dt, & + num_chem,var_rmv,chem,p_phy,t_phy, & + rho_phy,dqdti,rcav,rnav, & + ims,ime, jms,jme, kms,kme) + !if (chem_rc_check(localrc, msg="Failure in NGAC wet removal scheme", & + ! file=__FILE__, line=__LINE__, rc=rc)) return + case default + ! -- no further option implemented + end select + + + ! -- put chem stuff back into tracer array + do k=kts,kte + do i=its,ite + gq0(i,k,ntsmoke)=ppm2ugkg(p_oc1 ) * max(epsilc,chem(i,k,1,p_oc1)) + gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + enddo + enddo + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke)=gq0(i,k,ntsmoke) + qgrs(i,k,ntdust )=gq0(i,k,ntdust ) + enddo + enddo + + +! + end subroutine rrfs_smoke_lsdep_wrapper_run +!> @} + + subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,dqdti,z_at_w,vvel, & + ntsmoke,ntdust, & + ntrac,gq0,num_chem, num_moist, & + ppm2ugkg,moist,chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + implicit none + type(smoke_data), intent(inout) :: data + + !Chem input configuration + integer, intent(in) :: ktau + real(kind=kind_phys), intent(in) :: dtstep + + !FV3 input variables + integer, intent(in) :: ntrac,ntsmoke,ntdust + real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d + real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & + phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt + real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 + + + !GSD Chem variables + integer,intent(in) :: num_chem, num_moist + integer,intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & + rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, dqdti + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w + + ! -- local variables +! real(kind=kind_phys), dimension(ims:ime, kms:kme, jms:jme) :: p_phy + real(kind_phys) :: factor,factor2,pu,pl,aln,pwant + real(kind_phys) :: xhour,xmin,xlonn,xtime,real_time + real(kind_phys), DIMENSION (1,1) :: sza,cosszax + integer i,ip,j,jp,k,kp,kk,kkp,nv,jmax,jmaxi,l,ll,n,ndystep,ixhour + + ! -- initialize output arrays + rri = 0._kind_phys + t_phy = 0._kind_phys + u_phy = 0._kind_phys + v_phy = 0._kind_phys + p_phy = 0._kind_phys + rho_phy = 0._kind_phys + dz8w = 0._kind_phys + p8w = 0._kind_phys + t8w = 0._kind_phys + vvel = 0._kind_phys + dqdti = 0._kind_phys + moist = 0._kind_phys + chem = 0._kind_phys + z_at_w = 0._kind_phys + + + do j=jts,jte + jp = j - jts + 1 + do i=its,ite + ip = i - its + 1 + z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + p8w(i,k,j)=pr3d(ip,kp) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kk=min(k,kte) + kkp = kk - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) + t_phy(i,k,j)=tk3d(ip,kkp) + p_phy(i,k,j)=prl3d(ip,kkp) + u_phy(i,k,j)=us3d(ip,kkp) + dqdti(i,k,j)=dqdt(ip,kkp) + v_phy(i,k,j)=vs3d(ip,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + rri(i,k,j)=1./rho_phy(i,k,j) + vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + moist(i,k,j,:)=0. + moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + if (t_phy(i,k,j) > 265.) then + moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=0. + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. + else + moist(i,k,j,2)=0. + moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. + endif + !-- + enddo + enddo + enddo + + do j=jts,jte + do k=2,kte + do i=its,ite + t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) + enddo + enddo + enddo + + ! -- only used in phtolysis.... + do j=jts,jte + do i=its,ite + t8w(i,1,j)=t_phy(i,1,j) + t8w(i,kte+1,j)=t_phy(i,kte,j) + enddo + enddo + + + do k=kms,kte + do i=ims,ime + chem(i,k,jts,p_oc1 )=max(epsilc,gq0(i,k,ntsmoke)/ppm2ugkg(p_oc1)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + enddo + enddo + + + end subroutine rrfs_smoke_prep_lsdep +!> @} + end module rrfs_smoke_lsdep_wrapper diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/smoke/rrfs_smoke_lsdep_wrapper.meta new file mode 100755 index 000000000..7766ab2c4 --- /dev/null +++ b/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -0,0 +1,210 @@ +[ccpp-table-properties] + name = rrfs_smoke_lsdep_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_lsdep_wrapper_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_lsdep_wrapper_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_lsdep_wrapper_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[kme] + standard_name = vertical_interface_dimension + long_name = number of vertical levels plus one + units = count + dimensions = () + type = integer + intent = in +[ktau] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainc_cpl] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pr3d] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[ph3d] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[phl3d] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prl3d] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tk3d] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[us3d] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs3d] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[w] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dqdt] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[wetdep_ls_opt_in] + standard_name = rrfs_smoke_wetdep_ls_opt + long_name = rrfs smoke large scale wet deposition option + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 new file mode 100755 index 000000000..02ed273ae --- /dev/null +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -0,0 +1,73 @@ +!>\file rrfs_smoke_postpbl.F90 +!! This file is CCPP RRFS smoke postpbl driver +!! Haiqin.Li@noaa.gov 03/2022 + + module rrfs_smoke_postpbl + + use machine , only : kind_phys + use rrfs_smoke_config + + implicit none + + private + + public :: rrfs_smoke_postpbl_init, rrfs_smoke_postpbl_run, rrfs_smoke_postpbl_finalize + +contains + +!> \brief Brief description of the subroutine +!! + subroutine rrfs_smoke_postpbl_init() + end subroutine rrfs_smoke_postpbl_init + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_rrfs_smoke_postpbl_finalize Argument Table +!! + subroutine rrfs_smoke_postpbl_finalize() + end subroutine rrfs_smoke_postpbl_finalize + +!> \defgroup gsd_chem_group GSD Chem emission driver Module +!! This is the gsd chemistry +!>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem emission driver Module +!! \section arg_table_rrfs_smoke_postpbl_run Argument Table +!! \htmlinclude rrfs_smoke_postpbl_run.html +!! +!>\section rrfs_smoke_postpbl GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & + qgrs, chem3d, errmsg, errflg) + + implicit none + + + integer, intent(in) :: ite,kte,ntsmoke,ntdust,ntrac + + integer, parameter :: its=1,kts=1 + + real(kind_phys), dimension(ite,kte,ntrac), intent(inout) :: qgrs + real(kind_phys), dimension(ite,kte, 2), intent(inout) :: chem3d + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!>-- local variables + integer :: i, k + + errmsg = '' + errflg = 0 + + !--- put smoke stuff back into tracer array + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke)= chem3d(i,k,1) + qgrs(i,k,ntdust )= chem3d(i,k,2) + enddo + enddo + + end subroutine rrfs_smoke_postpbl_run + +!> @} + end module rrfs_smoke_postpbl diff --git a/smoke/rrfs_smoke_postpbl.meta b/smoke/rrfs_smoke_postpbl.meta new file mode 100755 index 000000000..e9597adc8 --- /dev/null +++ b/smoke/rrfs_smoke_postpbl.meta @@ -0,0 +1,85 @@ +[ccpp-table-properties] + name = rrfs_smoke_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_run + type = scheme +[ite] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 new file mode 100755 index 000000000..7b2cda56b --- /dev/null +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -0,0 +1,762 @@ +!>\file rrfs_smoke_wrapper.F90 +!! This file is CCPP RRFS smoke driver +!! Haiqin.Li@noaa.gov 02/2021 + + module rrfs_smoke_wrapper + + use physcons, only : g => con_g, pi => con_pi + use machine , only : kind_phys + use rrfs_smoke_config + use dust_data_mod + use seas_mod, only : gocart_seasalt_driver + use dust_fengsha_mod,only : gocart_dust_fengsha_driver + use plume_data_mod + use module_plumerise1 !plume_rise_mod + use module_add_emiss_burn + use dep_dry_mod + use rrfs_smoke_data + + implicit none + + private + + public :: rrfs_smoke_wrapper_init, rrfs_smoke_wrapper_run, rrfs_smoke_wrapper_finalize + +contains + +!> \brief Brief description of the subroutine +!! + subroutine rrfs_smoke_wrapper_init() + end subroutine rrfs_smoke_wrapper_init + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_rrfs_smoke_wrapper_finalize Argument Table +!! + subroutine rrfs_smoke_wrapper_finalize() + end subroutine rrfs_smoke_wrapper_finalize + +!> \defgroup gsd_chem_group GSD Chem emission driver Module +!! This is the gsd chemistry +!>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module +!> \ingroup gsd_chem_group +!! This is the GSD Chem emission driver Module +!! \section arg_table_rrfs_smoke_wrapper_run Argument Table +!! \htmlinclude rrfs_smoke_wrapper_run.html +!! +!>\section rrfs_smoke_wrapper GSD Chemistry Scheme General Algorithm +!> @{ + subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & + u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & + nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & + julian, idat, rain_cpl, rainc_cpl, exch, hf2d, & + dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & + ntsmoke, ntdust, imp_physics, imp_physics_thompson, & + nwfa, nifa, emanoc, & + emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & + coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, & + smoke_ext, dust_ext, & + seas_opt_in, dust_opt_in, biomass_burn_opt_in, drydep_opt_in, & + do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg) + + implicit none + + + integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) + integer, intent(in) :: ntrac, ntsmoke, ntdust + real(kind_phys),intent(in) :: dt, julian + logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in + + integer, parameter :: ids=1,jds=1,jde=1, kds=1 + integer, parameter :: ims=1,jms=1,jme=1, kms=1 + integer, parameter :: its=1,jts=1,jte=1, kts=1 + + integer, dimension(im), intent(in) :: land, vegtype, soiltyp + real(kind_phys), dimension(im,nsoil), intent(in) :: smc + real(kind_phys), dimension(im,12, 5), intent(in) :: dust12m_in + real(kind_phys), dimension(im,24, 3), intent(in) :: smoke_GBBEPx + real(kind_phys), dimension(im, 1), intent(in) :: emi_in + real(kind_phys), dimension(im), intent(in) :: u10m, v10m, ustar, dswsfc, & + garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & + rain_cpl, rainc_cpl, hf2d, t2m, dpt2m + real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + us3d, vs3d, spechum, exch, w + real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: qgrs, gq0 + real(kind_phys), dimension(im,kte, 2), intent(inout) :: chem3d + real(kind_phys), dimension(im), intent(inout) :: emdust, emseas, emanoc + real(kind_phys), dimension(im), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(im ), intent(inout) :: coef_bb, fhist + real(kind_phys), dimension(im,kte), intent(inout) :: ebu_smoke + real(kind_phys), dimension(im), intent(inout) :: max_fplume, min_fplume + real(kind_phys), dimension(im), intent( out) :: hwp + real(kind_phys), dimension(im,kte), intent(out) :: smoke_ext, dust_ext + real(kind_phys), dimension(im,kte), intent(inout) :: nwfa, nifa + integer, intent(in ) :: imp_physics, imp_physics_thompson + integer, intent(in) :: seas_opt_in, dust_opt_in, biomass_burn_opt_in, & + drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in + logical, intent(in ) :: do_plumerise_in + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ebu + real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & + p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, zmid, exch_h + + real(kind_phys), dimension(ims:im, jms:jme) :: u10, v10, ust, tsk, & + xland, xlat, xlong, dxy, pbl, hfx, rcav, rnav + +!>- sea salt & chemistry variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem + real(kind_phys), dimension(ims:im, 1, jms:jme, 1:num_emis_seas ) :: emis_seas + real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: dry_fall + real(kind_phys), dimension(ims:im, jms:jme) :: seashelp + + integer :: ide, ime, ite, kde, julday + +!>- dust & chemistry variables + real(kind_phys), dimension(ims:im, jms:jme) :: ssm, rdrag, uthr, snowh ! fengsha dust + real(kind_phys), dimension(ims:im, jms:jme) :: vegfrac, rmol, swdown, znt, clayf, sandf + real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois + real(kind_phys), dimension(ims:im, 1:1, jms:jme, 1:num_emis_dust) :: emis_dust + integer, dimension(ims:im, jms:jme) :: isltyp, ivgtyp + +!>- plume variables + ! -- buffers + real(kind_phys), dimension(ims:im, jms:jme) :: ebu_in + real(kind_phys), dimension(ims:im, jms:jme, num_frp_plume ) :: plume_frp + real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, & + fire_hist, peak_hr + real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: aod3d_smoke, aod3d_dust + integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 + real(kind_phys) :: dtstep + logical :: call_plume, scale_fire_emiss +!>- optical variables + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum + +!>-- anthropogentic variables +! real(kind_phys), dimension(ims:im, kms:kemit, jms:jme, 1:num_emis_ant) :: emis_ant + real(kind_phys), dimension(ims:im) :: emis_anoc + + real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ac3, ahno3, anh3, asulf, cor3, h2oai, h2oaj, nu3 + real(kind_phys), dimension(ims:im, jms:jme) :: dep_vel_o3, e_co + + real(kind_phys) :: gmt + real(kind_phys), dimension(1:num_chem) :: ppm2ugkg + +!> -- parameter to caluclate wfa&ifa (m) + real(kind_phys), parameter :: mean_diameter1= 4.E-8, sigma1=1.8 + real(kind_phys), parameter :: mean_diameter2= 1.E-6, sigma2=1.8 + real(kind_phys), parameter :: kappa_oc = 0.2 + real(kind_phys), parameter :: kappa_dust = 0.04 + real(kind_phys), parameter :: fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 + real(kind_phys), parameter :: fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 +!> -- aerosol density (kg/m3) + real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 + real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 + + real(kind_phys) :: daero_emis_wfa, daero_emis_ifa +!>-- local variables + real(kind_phys), dimension(im) :: wdgust, snoweq + integer :: current_month, current_hour + real(kind_phys) :: curr_secs + real(kind_phys) :: factor, factor2, factor3 + integer :: nbegin, nv, nvv + integer :: i, j, jp, k, kp, n + + type(smoke_data), pointer :: data + + data => get_thread_smoke_data() + + errmsg = '' + errflg = 0 + +!>-- options to turn on/off sea-salt, dust, plume-rising + seas_opt = seas_opt_in + dust_opt = dust_opt_in + biomass_burn_opt = biomass_burn_opt_in + drydep_opt = drydep_opt_in + do_plumerise = do_plumerise_in + plumerisefire_frq = plumerisefire_frq_in + addsmoke_flag = addsmoke_flag_in + smoke_forecast = smoke_forecast_in + aero_ind_fdb = aero_ind_fdb_in + dbg_opt = dbg_opt_in + + !print*,'hli ktau',ktau + ! -- set domain + ide=im + ime=im + ite=im + kde=kte + + h2oai = 0. + h2oaj = 0. + nu3 = 0. + ac3 = 0. + cor3 = 0. + asulf = 0. + ahno3 = 0. + anh3 = 0. + e_co = 0. + dep_vel_o3 = 0. + + min_fplume2 = 0 + max_fplume2 = 0 + emis_seas = 0. + emis_dust = 0. + peak_hr = 0. + flam_frac = 0. + aod3d_smoke = 0. + aod3d_dust = 0. + + rcav = 0. + rnav = 0. + + curr_secs = ktau * dt + current_month=jdate(2) + current_hour =jdate(5)+1 + gmt = real(idat(5)) + julday = int(julian) + + ! -- volume to mass fraction conversion table (ppm -> ug/kg) + ppm2ugkg = 1._kind_phys + ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + + ! -- compute incremental convective and large-scale rainfall + do i=its,ite + rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm + rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm + coef_bb_dc(i,1) = coef_bb(i) + fire_hist (i,1) = fhist (i) + enddo + + + ! plumerise frequency in minutes set up by the namelist input + call_plume = (biomass_burn_opt == BURN_OPT_ENABLE) .and. (plumerisefire_frq > 0) + if (call_plume) & + call_plume = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) & + .or. (ktau == 2) + + !scale_fire_emiss = .false. + + ! -- compute accumulated large-scale and convective rainfall since last call + if (ktau > 1) then + dtstep = call_chemistry * dt + else + dtstep = dt + end if + +!>- get ready for chemistry run + call rrfs_smoke_prep( & + ktau, current_month, current_hour, & + u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & + nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & + snow,dust12m_in,emi_in,smoke_GBBEPx, & + hf2d, pb2d, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,exch_h, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, ppm2ugkg, & + ntsmoke, ntdust, & + moist,chem,plume_frp,ebu_in, & + ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & + smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + +! Make this global, calculate at 1st time step only +!>-- for plumerise -- +!IF (ktau==1) THEN + do j=jts,jte + do i=its,ite + if (xlong(i,j)<-130.) then + peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska + elseif(xlong(i,j)<-115.) then + peak_hr(i,j)= 23.0* 3600. + elseif (xlong(i,j)<-100.) then + peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US + elseif (xlong(i,j)<-85.) then + peak_hr(i,j)= 21.0* 3600. + elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US + peak_hr(i,j)= 20.0* 3600. + else + peak_hr(i,j)= 19.0* 3600. + endif + enddo + enddo +!END IF + + IF (ktau==1) THEN + ebu = 0. + do j=jts,jte + do i=its,ite + ebu(i,kts,j)= ebu_in(i,j) + do k=kts+1,kte + ebu(i,k,j)= 0. + enddo + enddo + enddo + ELSE + do k=kts,kte + do i=its,ite + ebu(i,k,1)=ebu_smoke(i,k) + enddo + enddo + ENDIF + + +!>- compute sea-salt + ! -- compute sea salt + if (seas_opt >= SEAS_OPT_DEFAULT) then + call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & + u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & + xland,xlat,xlong,dxy,g,emis_seas, & + seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + endif + + !-- compute dust + select case (dust_opt) + case (DUST_OPT_FENGSHA) + ! Set at compile time in dust_data_mod: + call gocart_dust_fengsha_driver(data,dt,chem,rho_phy,smois,p8w,ssm, & + isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & + clayf,sandf,rdrag,uthr, & + num_emis_dust,num_moist,num_chem,nsoil, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + end select + + ! compute wild-fire plumes + !-- to add a namelist option to turn on/off plume raising + !--- replace plumerise_driver with HRRR-smoke 05/10/2021 + !-- /scratch2/BMC/ap-fc/Ravan/rapid-refresh/WRFV3.9/smoke + ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but + ! the plumerise is controlled by the namelist option of plumerise_flag + if (call_plume) then +! WRITE(*,*) 'plumerise is called at ktau= ',ktau + call ebu_driver ( & + data,flam_frac,ebu_in,ebu, & + t_phy,moist(:,:,:,p_qv), & + rho_phy,vvel,u_phy,v_phy,p_phy, & + z_at_w,zmid,ktau, & + plume_frp, min_fplume2, max_fplume2, & ! new approach + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + end if + + ! -- add biomass burning emissions at every timestep + if (addsmoke_flag == 1) then + call add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum,chem, & + julday,gmt,xlat,xlong, & + ivgtyp, vegfrac, peak_hr, & ! RAR + curr_secs,ebu, & + coef_bb_dc,fire_hist,aod3d_smoke,aod3d_dust, & + ! scalar(ims,kms,jms,P_QNWFA),scalar(ims,kms,jms,P_QNIFA), ! & + rcav, rnav,swdown,smoke_forecast, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif +! WRITE(*,*) 'after add_emis_burn at ktau= ',ktau + + !>-- compute dry deposition + if (drydep_opt == 1) then + call dry_dep_driver(data,ktau,dt,julday,current_month,t_phy,p_phy, & + moist,p8w,rmol,rri,gmt,t8w,rcav, & + chem,rho_phy,dz8w,exch_h,hfx, & + ivgtyp,tsk,swdown,vegfrac,pbl,ust,znt,zmid,z_at_w, & + xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & + anh3,dry_fall,dep_vel_o3,g, & + e_co,kemit,snowh,numgas, & + num_chem,num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + endif +! WRITE(*,*) 'dry depostion is done at ktau= ',ktau + + do k=kts,kte + do i=its,ite + ebu_smoke(i,k)=ebu(i,k,1) + enddo + enddo + + +!---- diagnostic output of hourly wildfire potential (07/2021) + hwp = 0. + do i=its,ite + wdgust(i)=1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2) + snoweq(i)=max((25.-snow(i)*1000.)/25.,0.) + !hwp(i)=44.09*wdgust(i)**1.82*max(0.,t2m(i)-dpt2m(i))**0.61*max(0.,1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + hwp(i)=44.09*wdgust(i)**1.82*(t2m(i)-dpt2m(i))**0.61*(1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + enddo + +!---- diagnostic output of smoke & dust optical extinction (12/2021) + do k=kts,kte + do i=its,ite + smoke_ext(i,k) = aod3d_smoke(i,k,1) + dust_ext (i,k) = aod3d_dust (i,k,1) + enddo + enddo +!------------------------------------- +!---- put smoke stuff back into tracer array + do k=kts,kte + do i=its,ite + gq0(i,k,ntsmoke )=ppm2ugkg(p_smoke ) * max(epsilc,chem(i,k,1,p_smoke)) ! + gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + enddo + enddo + + do k=kts,kte + do i=its,ite + qgrs(i,k,ntsmoke )= gq0(i,k,ntsmoke ) + qgrs(i,k,ntdust )= gq0(i,k,ntdust ) + chem3d(i,k,1 )= gq0(i,k,ntsmoke ) + chem3d(i,k,2 )= gq0(i,k,ntdust ) + enddo + enddo +!------------------------------------- +!-- to output for diagnostics +! WRITE(*,*) 'rrfs nwfa/nifa 1 at ktau= ',ktau + do i = 1, im + emseas (i) = emis_seas (i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s + emdust (i) = emis_dust (i,1,1,1) ! size bin 1 dust emission : ug/m2/s + emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s + coef_bb (i) = coef_bb_dc (i,1) + fhist (i) = fire_hist (i,1) + min_fplume (i) = real(min_fplume2(i,1)) + max_fplume (i) = real(max_fplume2(i,1)) + enddo + +! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau +!-- to provide real aerosol emission for Thompson MP + if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then + + do i = its, ite + do k = kts, kte + if (k==1)then + daero_emis_wfa =(emanoc(i)+ebu_smoke(i,k))/density_oc + emseas(i)/density_seasalt + else + daero_emis_wfa = ebu_smoke(i,k)/density_oc + endif + daero_emis_wfa = kappa_oc* daero_emis_wfa*fact_wfa*rri(i,k,1)/dz8w(i,k,1) ! consider using dust tracer + + nwfa(i,k) = nwfa(i,k) + daero_emis_wfa*dt + nifa(i,k) = gq0(i,k,ntdust)/density_dust*fact_ifa*kappa_dust ! Check the formula + + if(land(i).eq.1)then + nwfa(i,k) = nwfa(i,k)*(1 - 0.10*dt/86400.) !-- mimicking dry deposition + else + nwfa(i,k) = nwfa(i,k)*(1 - 0.05*dt/86400.) !-- mimicking dry deposition + endif + enddo + enddo + endif +! WRITE(*,*) 'rrfs smoke wrapper is done at ktau= ',ktau + + end subroutine rrfs_smoke_wrapper_run + + subroutine rrfs_smoke_prep( & + ktau,current_month,current_hour, & + u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & + nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & + snow_cpl,dust12m_in,emi_in,smoke_GBBEPx, & + hf2d, pb2d, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & + t8w,exch_h, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, ppm2ugkg, & + ntsmoke, ntdust, & + !num_emis_ant, & + !emis_ant, & + moist,chem,plume_frp,ebu_in, & + ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & + smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & + snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + !Chem input configuration + integer, intent(in) :: ktau, current_month, current_hour + + !FV3 input variables + integer, intent(in) :: nsoil + integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp + integer, intent(in) :: ntrac + real(kind=kind_phys), dimension(ims:ime), intent(in) :: & + u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & + zorl, snow_cpl, pb2d, hf2d + real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc + real(kind=kind_phys), dimension(ims:ime, 12, 5), intent(in) :: dust12m_in + real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_GBBEPx + real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_in + real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d + real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & + phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w + real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 + + + !GSD Chem variables + !integer,intent(in) :: num_emis_ant + integer,intent(in) :: num_chem, num_moist, ntsmoke, ntdust + integer,intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + + !real(kind_phys), dimension(ims:ime, kms:kemit, jms:jme, num_emis_ant), intent(inout) :: emis_ant + real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg + real(kind_phys), dimension(ims:ime, jms:jme),intent(out) :: ebu_in + real(kind_phys), dimension(ims:ime, jms:jme, num_frp_plume), intent(out) :: plume_frp + + integer,dimension(ims:ime, jms:jme), intent(out) :: isltyp, ivgtyp + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & + rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, & + zmid, exch_h, rel_hum + real(kind_phys), dimension(ims:ime, jms:jme), intent(out) :: & + u10, v10, ust, tsk, xland, xlat, xlong, dxy, vegfrac, rmol, swdown, znt, & + pbl, hfx, snowh, clayf, rdrag, sandf, ssm, uthr + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem + + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w + real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois + real(kind_phys), dimension(ims:ime), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc + !real(kind_phys), dimension(ims:ime, jms:jme, num_plume_data) :: plume + real(kind_phys), parameter :: conv_frp = 1.e+06_kind_phys ! FRP conversion factor, MW to W + real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) + + ! -- local variables + integer i,ip,j,jp,k,kp,kk,kkp,nv,l,ll,n + + ! -- initialize fire emissions + !plume = 0._kind_phys + plume_frp = 0._kind_phys + ebu_in = 0._kind_phys + ebb_smoke_hr = 0._kind_phys + emis_anoc = 0._kind_phys + + ! -- initialize output arrays + isltyp = 0._kind_phys + ivgtyp = 0._kind_phys + rri = 0._kind_phys + t_phy = 0._kind_phys + u_phy = 0._kind_phys + v_phy = 0._kind_phys + p_phy = 0._kind_phys + rho_phy = 0._kind_phys + dz8w = 0._kind_phys + p8w = 0._kind_phys + t8w = 0._kind_phys + vvel = 0._kind_phys + zmid = 0._kind_phys + exch_h = 0._kind_phys + u10 = 0._kind_phys + v10 = 0._kind_phys + ust = 0._kind_phys + tsk = 0._kind_phys + xland = 0._kind_phys + xlat = 0._kind_phys + xlong = 0._kind_phys + dxy = 0._kind_phys + vegfrac = 0._kind_phys + rmol = 0._kind_phys + swdown = 0._kind_phys + znt = 0._kind_phys + hfx = 0._kind_phys + pbl = 0._kind_phys + snowh = 0._kind_phys + clayf = 0._kind_phys + rdrag = 0._kind_phys + sandf = 0._kind_phys + ssm = 0._kind_phys + uthr = 0._kind_phys + moist = 0._kind_phys + chem = 0._kind_phys + z_at_w = 0._kind_phys + rel_hum = 0._kind_phys + + do i=its,ite + u10 (i,1)=u10m (i) + v10 (i,1)=v10m (i) + tsk (i,1)=ts2d (i) + ust (i,1)=ustar(i) + dxy (i,1)=garea(i) + xland(i,1)=real(land(i)) + xlat (i,1)=rlat(i)*180./pi + xlong(i,1)=rlon(i)*180./pi + swdown(i,1)=dswsfc(i) + znt (i,1)=zorl(i)*0.01 + hfx (i,1)=hf2d(i) + pbl (i,1)=pb2d(i) + snowh(i,1)=snow_cpl(i)*0.001 + clayf(i,1)=dust12m_in(i,current_month,1) + rdrag(i,1)=dust12m_in(i,current_month,2) + sandf(i,1)=dust12m_in(i,current_month,3) + ssm (i,1)=dust12m_in(i,current_month,4) + uthr (i,1)=dust12m_in(i,current_month,5) + ivgtyp (i,1)=vegtype(i) + isltyp (i,1)=soiltyp(i) + vegfrac(i,1)=sigmaf (i) + enddo + + rmol=0. + + do k=1,nsoil + do j=jts,jte + do i=its,ite + smois(i,k,j)=smc(i,k) + enddo + enddo + enddo + + !if (ktau <= 1) then + ! emis_ant = 0. + ! !emis_vol = 0. + !end if + + do j=jts,jte + jp = j - jts + 1 + do i=its,ite + ip = i - its + 1 + z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kp = k - kts + 1 + do i=its,ite + ip = i - its + 1 + p8w(i,k,j)=pr3d(ip,kp) + enddo + enddo + enddo + + do j=jts,jte + jp = j - jts + 1 + do k=kts,kte+1 + kk=min(k,kte) + kkp = kk - kts + 1 + do i=its,ite + ip = i - its + 1 + dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) + t_phy(i,k,j)=tk3d(ip,kkp) + p_phy(i,k,j)=prl3d(ip,kkp) + u_phy(i,k,j)=us3d(ip,kkp) + v_phy(i,k,j)=vs3d(ip,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + rri(i,k,j)=1./rho_phy(i,k,j) + vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + moist(i,k,j,:)=0. + moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + if (t_phy(i,k,j) > 265.) then + moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=0. + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. + else + moist(i,k,j,2)=0. + moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. + endif + rel_hum(i,k,j) = .95 + rel_hum(i,k,j) = MIN( .95, moist(i,k,j,1) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) + rel_hum(i,k,j)=max(0.1,rel_hum(i,k,j)) + !-- + zmid(i,k,j)=phl3d(ip,kkp)/g + enddo + enddo + enddo + + ! -- the imported atmospheric heat diffusivity is only available up to kte-1 + do k=kts,kte-1 + do i=its,ite + exch_h(i,k,1)=exch(i,k) + enddo + enddo + + do j=jts,jte + do k=2,kte + do i=its,ite + t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) + enddo + enddo + enddo + + ! -- only used in phtolysis.... + do j=jts,jte + do i=its,ite + t8w(i,1,j)=t_phy(i,1,j) + t8w(i,kte+1,j)=t_phy(i,kte,j) + enddo + enddo + + ! -- anthropogenic organic carbon + do i=its,ite + emis_anoc(i) = emi_in(i,1) + enddo + + ! select case (plumerise_flag) + ! case (FIRE_OPT_GBBEPx) + do j=jts,jte + do i=its,ite + ebb_smoke_hr(i) = smoke_GBBEPx(i,current_hour,1) ! smoke + frp_hr (i) = smoke_GBBEPx(i,current_hour,2) ! frp + frp_std_hr (i) = smoke_GBBEPx(i,current_hour,3) ! std frp + ebu_in (i,j) = ebb_smoke_hr(i) + plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) + plume_frp(i,j,p_frp_std ) = conv_frp* frp_std_hr (i) + enddo + enddo + ! case default + ! end select + + ! We will add a namelist variable, real :: flam_frac_global + + do k=kms,kte + do i=ims,ime + chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )/ppm2ugkg(p_smoke)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + enddo + enddo + + + + end subroutine rrfs_smoke_prep + +!> @} + end module rrfs_smoke_wrapper diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta new file mode 100755 index 000000000..867550f50 --- /dev/null +++ b/smoke/rrfs_smoke_wrapper.meta @@ -0,0 +1,632 @@ +[ccpp-table-properties] + name = rrfs_smoke_wrapper + type = scheme + dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[kte] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[kme] + standard_name = vertical_interface_dimension + long_name = number of vertical levels plus one + units = count + dimensions = () + type = integer + intent = in +[ktau] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = grid cell area + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[land] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[jdate] + standard_name = date_and_time_of_forecast_in_united_states_order + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in +[u10m] + standard_name = x_wind_at_10m + long_name = 10 meter u wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v10m] + standard_name = y_wind_at_10m + long_name = 10 meter v wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tskin] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pb2d] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t2m] + standard_name = air_temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dpt2m] + standard_name = dewpoint_temperature_at_2m + long_name = 2 meter dewpoint temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pr3d] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[ph3d] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[phl3d] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prl3d] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tk3d] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[us3d] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs3d] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[w] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[nsoil] + standard_name = vertical_dimension_of_soil + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[smc] + standard_name = volume_fraction_of_condensed_water_in_soil + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dswsfc] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snow] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[julian] + standard_name = forecast_julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = in +[idat] + standard_name = date_and_time_at_model_initialization_in_iso_order + long_name = initialization date and time + units = none + dimensions = (8) + type = integer + intent = in +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainc_cpl] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[exch] + standard_name = atmosphere_heat_diffusivity + long_name = diffusivity for heat + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[hf2d] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux valid for current call + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dust12m_in] + standard_name = fengsha_dust12m_input + long_name = fengsha dust input + units = various + dimensions = (horizontal_loop_extent,12,5) + type = real + kind = kind_phys + intent = in +[emi_in] + standard_name = anthropogenic_background_input + long_name = anthropogenic background input + units = various + dimensions = (horizontal_loop_extent,1) + type = real + kind = kind_phys + intent = in +[smoke_GBBEPx] + standard_name = emission_smoke_GBBEPx + long_name = emission fire GBBEPx + units = various + dimensions = (horizontal_loop_extent,24,3) + type = real + kind = kind_phys + intent = in +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[tile_num] + standard_name = index_of_cubed_sphere_tile + long_name = tile number + units = none + dimensions = () + type = integer + intent = in +[ntsmoke] + standard_name = index_for_smoke + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_thompson] + standard_name = identifier_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[nwfa] + standard_name = mass_number_concentration_of_hygroscopic_aerosols_of_new_state + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[nifa] + standard_name = mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_of_new_state + long_name = number concentration of ice-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[emanoc] + standard_name = emission_of_anoc_for_thompson_mp + long_name = emission of anoc for thompson mp + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[emdust] + standard_name = emission_of_dust_for_smoke + long_name = emission of dust for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[emseas] + standard_name = emission_of_seas_for_smoke + long_name = emission of seas for smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ebb_smoke_hr] + standard_name = surfce_emission_of_smoke + long_name = emission of surface smoke + units = ug m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[frp_hr] + standard_name = frp_hourly + long_name = hourly frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[frp_std_hr] + standard_name = frp_std_hourly + long_name = hourly std frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[coef_bb] + standard_name = coef_bb_dc + long_name = coef bb dc from plumerise + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ebu_smoke] + standard_name = ebu_smoke + long_name = smoke buffer of ebu + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[fhist] + standard_name = fhist + long_name = fire hist + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[min_fplume] + standard_name = min_fplume + long_name = miminum plume height + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[max_fplume] + standard_name = max_fplume + long_name = maximum plume height + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hwp] + standard_name = rrfs_hwp + long_name = rrfs hourly fire weather potential + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[smoke_ext] + standard_name = smoke_ext + long_name = smoke optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dust_ext] + standard_name = dust_ext + long_name = dust optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[seas_opt_in] + standard_name = rrfs_smoke_sea_salt_opt + long_name = rrfs smoke sea salt emission option + units = index + dimensions = () + type = integer + intent = in +[dust_opt_in] + standard_name = rrfs_smoke_dust_opt + long_name = rrfs smoke dust chem option + units = index + dimensions = () + type = integer + intent = in +[biomass_burn_opt_in] + standard_name = rrfs_smoke_biomass_burn_opt + long_name = rrfs smoke biomass burning option + units = index + dimensions = () + type = integer + intent = in +[drydep_opt_in] + standard_name = rrfs_smoke_drydep_opt + long_name = rrfs smoke dry deposition option + units = index + dimensions = () + type = integer + intent = in +[do_plumerise_in] + standard_name = rrfs_smoke_plumerise_flag + long_name = rrfs smoke plumerise option + units = index + dimensions = () + type = logical + intent = in +[plumerisefire_frq_in] + standard_name = rrfs_smoke_plumerisefire_frq + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[addsmoke_flag_in] + standard_name = rrfs_smoke_addsmoke_flag + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[smoke_forecast_in] + standard_name = rrfs_smoke_smoke_forecast_opt + long_name = flag for rrfs smoke forecast + units = flag + dimensions = () + type = logical + intent = in +[aero_ind_fdb_in] + standard_name = rrfs_smoke_aero_ind_fdb_opt + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + intent = in +[dbg_opt_in] + standard_name = rrfs_smoke_plumerise_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/smoke/seas_data_mod.F90 b/smoke/seas_data_mod.F90 new file mode 100755 index 000000000..6602d58a2 --- /dev/null +++ b/smoke/seas_data_mod.F90 @@ -0,0 +1,18 @@ +module seas_data_mod + + use machine , only : kind_phys + + ! -- parameters from NGAC v2.4.0 (rev. d48932c) + integer, parameter :: number_ss_bins = 5 + ! -- lower/upper particle radii (um) for each bin + real(kind=kind_phys), dimension(number_ss_bins), parameter :: ra = (/ 0.03, 0.1, 0.5, 1.5, 5.0 /) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: rb = (/ 0.1, 0.5, 1.5, 5.0, 10.0 /) + ! -- global scaling factors for sea salt emissions (originally 0.875 in NGAC namelist) + !real(kind=kind_phys), dimension(number_ss_bins), parameter :: emission_scale = (/ 0.100, 0.100, 0.100, 0.100, 0.100 /) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: emission_scale = (/ 1.0, 1.0, 1.0, 1.0, 1.0 /) + ! -- sea salt density + real(kind=kind_phys), dimension(number_ss_bins), parameter :: den_seas = (/ 2200., 2200., 2200., 2200., 2200. /) + ! -- particle effective radius (m) + real(kind=kind_phys), dimension(number_ss_bins), parameter :: reff_seas = (/ 0.079e-6, 0.316e-6, 1.119e-6, 2.818e-6, 7.772e-6 /) + +end module seas_data_mod diff --git a/smoke/seas_mod.F90 b/smoke/seas_mod.F90 new file mode 100755 index 000000000..a610884d6 --- /dev/null +++ b/smoke/seas_mod.F90 @@ -0,0 +1,429 @@ +module seas_mod + + use machine , only : kind_phys + use physcons, only : pi=>con_pi +! use chem_rc_mod, only : chem_rc_test +! use chem_tracers_mod, only : p_seas_1, p_seas_2, p_seas_3, p_seas_4, p_seas_5, & +! p_eseas1, p_eseas2, p_eseas3, p_eseas4, p_eseas5, & +! config => chem_config + use seas_data_mod + use seas_ngac_mod + + implicit none + + integer, parameter :: SEAS_OPT_DEFAULT = 1 + integer, parameter :: CHEM_OPT_GOCART = 300 + integer, parameter :: chem_opt = 300 + + ! -- NGAC parameters + integer, parameter :: emission_scheme = 3 ! GEOSS 2012 + + private + + public :: SEAS_OPT_DEFAULT + + public :: gocart_seasalt_driver + +CONTAINS + + subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & + v_phy,chem,rho_phy,dz8w,u10,v10,ustar,p8w,tsk, & + xland,xlat,xlong,area,g,emis_seas, & + seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + INTEGER, INTENT(IN ) :: ktau,num_emis_seas,num_moist,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,seas_opt + REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_seas), & + INTENT(OUT ) :: & + emis_seas + REAL(kind=kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + u10, & + v10, & + ustar,tsk, & + xland, & + xlat, & + xlong,area + REAL(kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT ) :: seashelp + REAL(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + alt, & + t_phy, & + dz8w,p8w, & + u_phy,v_phy,rho_phy + + REAL(kind=kind_phys), INTENT(IN ) :: dt,g +! + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 + + integer, parameter :: p_eseas1=1 + integer, parameter :: p_eseas2=2 + integer, parameter :: p_eseas3=3 + integer, parameter :: p_eseas4=4 + integer, parameter :: p_eseas5=5 +! +! local variables +! + integer :: ipr,i,j,imx,jmx,lmx,n,rc,chem_config + integer,dimension (1,1) :: ilwi + real(kind=kind_phys) :: fsstemis, memissions, nemissions, tskin_c, ws10m + real(kind=kind_phys) :: delp + real(kind=kind_phys), DIMENSION (number_ss_bins) :: tc,bems + real(kind=kind_phys), dimension (1,1) ::w10m,airmas,tskin + real(kind=kind_phys), dimension (1) :: dxy + + real(kind=kind_phys), dimension(1,1,1) :: airmas1 + real(kind=kind_phys), dimension(1,1,1,number_ss_bins) :: tc1 + real(kind=kind_phys), dimension(1,1,number_ss_bins) :: bems1 + +! +! local parameters +! + real(kind=kind_phys), parameter :: conver = 1.e-9_kind_phys + real(kind=kind_phys), parameter :: converi = 1.e+9_kind_phys +! +! number of dust bins +! + imx=1 + jmx=1 + lmx=1 + + chem_config=CHEM_OPT_GOCART + + emis_seas = 0. + +! select case (config % chem_opt) + select case (chem_opt) + + case (304, 316, 317) + + seashelp(:,:)=0. + do j=jts,jte + do i=its,ite +! +! don't do dust over water!!! +! + if(xland(i,j).lt.0.5)then + ilwi(1,1)=0 + tc(1)=chem(i,kts,j,p_seas_1)*conver + tc(2)=1.e-30_kind_phys + tc(3)=chem(i,kts,j,p_seas_2)*conver + tc(4)=1.e-30_kind_phys + w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + tskin(1,1)=tsk(i,j) + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + airmas(1,1)=area(i,j) * delp / g +! +! we don't trust the u10,v10 values, is model layers are very thin near surface +! + if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) +! + dxy(1)=area(i,j) + ipr=0 + + airmas1(1,1,1) = airmas(1,1) + tc1(1,1,1,:) = tc + bems1(1,1,:) = bems + call source_ss( imx, jmx, lmx, number_ss_bins, dt, tc1,ilwi, dxy, w10m, airmas1, bems1,ipr) + tc = tc1(1,1,1,:) + chem(i,kts,j,p_seas_1)=(tc(1)+.75*tc(2))*converi + chem(i,kts,j,p_seas_2)=(tc(3)+.25*tc(2))*converi + seashelp(i,j)=tc(2)*converi + endif + enddo + enddo + + case default + + select case (seas_opt) + case (1) + ! -- original GOCART sea salt scheme + do j = jts, jte + do i = its, ite + + ! -- only use sea salt scheme over water + if (xland(i,j) < 0.5) then + + ! -- compute auxiliary variables + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + if (dz8w(i,kts,j) < 12.) then + w10m = sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) + else + w10m = sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + end if + + ilwi(1,1)=0 + tc = 0. + tskin(1,1)=tsk(i,j) + airmas(1,1)=area(i,j) * delp / g + dxy(1)=area(i,j) + ipr=0 + + airmas1(1,1,1) = airmas(1,1) + tc1(1,1,1,:) = tc + bems1(1,1,:) = bems + call source_ss( imx,jmx,lmx,number_ss_bins, dt, tc1, ilwi, dxy, w10m, airmas1, bems1,ipr) + tc = tc1(1,1,1,:) + bems = bems1(1,1,:) + + ! -- add sea salt emission increments to existing airborne concentrations + chem(i,kts,j,p_seas_1) = chem(i,kts,j,p_seas_1) + tc(1)*converi + chem(i,kts,j,p_seas_2) = chem(i,kts,j,p_seas_2) + tc(2)*converi + chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi + chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi + chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi + !print*,'hli tc(2),chem(i,kts,j,p_seas_2)',tc(2),chem(i,kts,j,p_seas_2) + + ! for output diagnostics + emis_seas(i,1,j,p_eseas1) = bems(1) + emis_seas(i,1,j,p_eseas2) = bems(2) + emis_seas(i,1,j,p_eseas3) = bems(3) + emis_seas(i,1,j,p_eseas4) = bems(4) + emis_seas(i,1,j,p_eseas5) = bems(5) + + end if + + end do + end do + + case (2) + ! -- NGAC sea salt scheme + do j = jts, jte + do i = its, ite + + ! -- only use sea salt scheme over water + if (xland(i,j) < 0.5) then + + ! -- compute auxiliary variables + delp = p8w(i,kts,j)-p8w(i,kts+1,j) + if (dz8w(i,kts,j) < 12.) then + ws10m = sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) + else + ws10m = sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + end if + + ! -- compute NGAC SST correction + tskin_c = tsk(i,j) - 273.15 + tskin_c = min(max(tskin_c, -0.1), 36.0) ! temperature range (0, 36) C + + fsstemis = -1.107211 & + - tskin_c*(0.010681+0.002276*tskin_c) & + + 60.288927/(40.0 - tskin_c) + fsstemis = min(max(fsstemis, 0.0), 7.0) + + do n = 1, number_ss_bins + memissions = 0. + nemissions = 0. + call SeasaltEmission( ra(n), rb(n), emission_scheme, & + ws10m, ustar(i,j), memissions, nemissions, rc ) +! if (chem_rc_test((rc /= 0), msg="Error in NGAC sea salt scheme", & +! file=__FILE__, line=__LINE__)) return + + bems(n) = emission_scale(n) * fsstemis * memissions + tc(n) = bems(n) * dt * g / delp + end do + + ! -- add sea salt emission increments to existing airborne concentrations + chem(i,kts,j,p_seas_1) = chem(i,kts,j,p_seas_1) + tc(1)*converi + chem(i,kts,j,p_seas_2) = chem(i,kts,j,p_seas_2) + tc(2)*converi + chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi + chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi + chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi + + ! for output diagnostics kg/m2/s + emis_seas(i,1,j,p_eseas1) = bems(1) + emis_seas(i,1,j,p_eseas2) = bems(2) + emis_seas(i,1,j,p_eseas3) = bems(3) + emis_seas(i,1,j,p_eseas4) = bems(4) + emis_seas(i,1,j,p_eseas5) = bems(5) + end if + + end do + end do + + case default + ! -- no sea salt scheme + + end select + + end select + + end subroutine gocart_seasalt_driver + + SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, & + ilwi, dxy, w10m, airmas, & + bems,ipr) + +! **************************************************************************** +! * Evaluate the source of each seasalt particles size classes (kg/m3) +! * by soil emission. +! * Input: +! * SSALTDEN Sea salt density (kg/m3) +! * DXY Surface of each grid cell (m2) +! * NDT1 Time step (s) +! * W10m Velocity at the anemometer level (10meters) (m/s) +! * +! * Output: +! * DSRC Source of each sea salt bins (kg/timestep/cell) +! * +! * +! * Number flux density: Original formula by Monahan et al. (1986) adapted +! * by Sunling Gong (JGR 1997 (old) and GBC 2003 (new)). The new version is +! * to better represent emission of sub-micron sea salt particles. +! +! * dFn/dr = c1*u10**c2/(r**A) * (1+c3*r**c4)*10**(c5*exp(-B**2)) +! * where B = (b1 -log(r))/b2 +! * see c_old, c_new, b_old, b_new below for the constants. +! * number fluxes are at 80% RH. +! * +! * To calculate the flux: +! * 1) Calculate dFn based on Monahan et al. (1986) and Gong (2003) +! * 2) Assume that wet radius r at 80% RH = dry radius r_d *frh +! * 3) Convert particles flux to mass flux : +! * dFM/dr_d = 4/3*pi*rho_d*r_d^3 *(dr/dr_d) * dFn/dr +! * = 4/3*pi*rho_d*r_d^3 * frh * dFn/dr +! * where rho_p is particle density [kg/m3] +! * The factor 1.e-18 is to convert in micro-meter r_d^3 +! **************************************************************************** + + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,ipr + INTEGER, INTENT(IN) :: ilwi(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: dxy(jmx), w10m(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) + REAL(kind=kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) + + REAL(kind=kind_phys) :: c0(5), b0(2) +! REAL(kind=kind_phys), PARAMETER :: c_old(5)=(/1.373, 3.41, 0.057, 1.05, 1.190/) +! REAL(kind=kind_phys), PARAMETER :: c_new(5)=(/1.373, 3.41, 0.057, 3.45, 1.607/) + ! Change suggested by MC + REAL(kind=kind_phys), PARAMETER :: c_old(5)=(/1.373, 3.2, 0.057, 1.05, 1.190/) + REAL(kind=kind_phys), PARAMETER :: c_new(5)=(/1.373, 3.2, 0.057, 3.45, 1.607/) + REAL(kind=kind_phys), PARAMETER :: b_old(2)=(/0.380, 0.650/) + REAL(kind=kind_phys), PARAMETER :: b_new(2)=(/0.433, 0.433/) + REAL(kind=kind_phys), PARAMETER :: dr=5.0D-2 ! um + REAL(kind=kind_phys), PARAMETER :: theta=30.0 + ! Swelling coefficient frh (d rwet / d rd) +!!! REAL(kind=kind_phys), PARAMETER :: frh = 1.65 + REAL(kind=kind_phys), PARAMETER :: frh = 2.d0 + LOGICAL, PARAMETER :: old=.TRUE., new=.FALSE. + REAL(kind=kind_phys) :: rho_d, r0, r1, r, r_w, a, b, dfn, r_d, dfm, src + INTEGER :: i, j, n, nr, ir + REAL(kind=kind_phys) :: dt1,fudge_fac + + + REAL(kind=kind_phys) :: tcmw(nmx), ar(nmx), tcvv(nmx) + REAL(kind=kind_phys) :: ar_wetdep(nmx), kc(nmx) + CHARACTER(LEN=20) :: tcname(nmx), tcunits(nmx) + LOGICAL :: aerosol(nmx) + + + REAL(kind=kind_phys) :: tc1(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), TARGET :: tcms(imx,jmx,lmx,nmx) ! tracer mass (kg; kgS for sulfur case) + REAL(kind=kind_phys), TARGET :: tcgm(imx,jmx,lmx,nmx) ! g/m3 + + !----------------------------------------------------------------------- + ! sea salt specific + !----------------------------------------------------------------------- +! REAL(kind=kind_phys), DIMENSION(nmx) :: ra, rb +! REAL(kind=kind_phys) :: ch_ss(nmx,12) + + !----------------------------------------------------------------------- + ! emissions (input) + !----------------------------------------------------------------------- + REAL(kind=kind_phys) :: e_an(imx,jmx,2,nmx), e_bb(imx,jmx,nmx), & + e_ac(imx,jmx,lmx,nmx) + + !----------------------------------------------------------------------- + ! diagnostics (budget) + !----------------------------------------------------------------------- +! ! tendencies per time step and process +! REAL(kind=kind_phys), TARGET :: bems(imx,jmx,nmx), bdry(imx,jmx,nmx), bstl(imx,jmx,nmx) +! REAL(kind=kind_phys), TARGET :: bwet(imx,jmx,nmx), bcnv(imx,jmx,nmx)! + +! ! integrated tendencies per process +! REAL(kind=kind_phys), TARGET :: tems(imx,jmx,nmx), tstl(imx,jmx,nmx) +! REAL(kind=kind_phys), TARGET :: tdry(imx,jmx,nmx), twet(imx,jmx,nmx), tcnv(imx,jmx,nmx) + + ! global mass balance per time step + REAL(kind=kind_phys) :: tmas0(nmx), tmas1(nmx) + REAL(kind=kind_phys) :: dtems(nmx), dttrp(nmx), dtdif(nmx), dtcnv(nmx) + REAL(kind=kind_phys) :: dtwet(nmx), dtdry(nmx), dtstl(nmx) + REAL(kind=kind_phys) :: dtems2(nmx), dttrp2(nmx), dtdif2(nmx), dtcnv2(nmx) + REAL(kind=kind_phys) :: dtwet2(nmx), dtdry2(nmx), dtstl2(nmx) + + ! detailed integrated budgets for individual emissions + REAL(kind=kind_phys), TARGET :: ems_an(imx,jmx,nmx), ems_bb(imx,jmx,nmx), ems_tp(imx,jmx) + REAL(kind=kind_phys), TARGET :: ems_ac(imx,jmx,lmx,nmx) + REAL(kind=kind_phys), TARGET :: ems_co(imx,jmx,nmx) + + ! executable statements +! decrease seasalt emissions (Colarco et al. 2010) +! + !fudge_fac= 1. !.5 + !fudge_fac= .5 !lzhang + fudge_fac= .25 !lzhang +! + DO n = 1,nmx + bems(:,:,n) = 0.0 + rho_d = den_seas(n) + r0 = ra(n)*frh + r1 = rb(n)*frh + r = r0 + nr = INT((r1-r0)/dr+.001) + DO ir = 1,nr + r_w = r + dr*0.5 + r = r + dr + IF (new) THEN + a = 4.7*(1.0 + theta*r_w)**(-0.017*r_w**(-1.44)) + c0 = c_new + b0 = b_new + ELSE + a = 3.0 + c0 = c_old + b0 = b_old + END IF + ! + b = (b0(1) - LOG10(r_w))/b0(2) + dfn = (c0(1)/r_w**a)*(1.0 + c0(3)*r_w**c0(4))* & + 10**(c0(5)*EXP(-(b**2))) + + r_d = r_w/frh*1.0D-6 ! um -> m + dfm = 4.0/3.0*pi*r_d**3*rho_d*frh*dfn*dr*dt1 ! 3600 !dt1 + DO i = 1,imx + DO j = 1,jmx +! IF (water(i,j) > 0.0) THEN + IF (ilwi(i,j) == 0) THEN +! src = dfm*dxy(j)*water(i,j)*w10m(i,j)**c0(2) + src = dfm*dxy(j)*w10m(i,j)**c0(2) +! src = ch_ss(n,dt(1)%mn)*dfm*dxy(j)*w10m(i,j)**c0(2) + tc(i,j,1,n) = tc(i,j,1,n) + fudge_fac*src/airmas(i,j,1) + ELSE + src = 0.0 + END IF + bems(i,j,n) = bems(i,j,n) + src*fudge_fac/(dxy(j)*dt1) !kg/m2/s + END DO ! i + END DO ! j + END DO ! ir + END DO ! n + + END SUBROUTINE source_ss + +end module seas_mod diff --git a/smoke/seas_ngac_mod.F90 b/smoke/seas_ngac_mod.F90 new file mode 100755 index 000000000..73605ecc1 --- /dev/null +++ b/smoke/seas_ngac_mod.F90 @@ -0,0 +1,188 @@ +!------------------------------------------------------------------------- +! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! +! Adapted by NOAA/GSD/ESRL ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: seas_ngac_mod.F90 --- Calculate the Seasalt Emissions +! +! !INTERFACE: +! + + module seas_ngac_mod + +! !USES: + +! use chem_comm_mod, only : chem_comm_isroot + use machine , only : kind_phys + use physcons, only : pi=>con_pi + + implicit none + +! !PUBLIC TYPES: +! + PRIVATE + +! +! !PUBLIC MEMBER FUNCTIONS: +! + + PUBLIC SeasaltEmission + + +! !CONSTANTS + real(kind=kind_phys), parameter :: r80fac = 1.65 ! ratio of radius(RH=0.8)/radius(RH=0.) [Gerber] + real(kind=kind_phys), parameter :: rhop = 2200. ! dry seasalt density [kg m-3] + +! +! !DESCRIPTION: +! +! This module implements the sea salt aerosol emission parameterizations. +! For all variants, emissions are some function of wind speed (and possibly +! other dynamical parameters) and the sea salt particle radius. Here, +! we assume the model passes in dry radius (or dry radius of size bin edges). +! Output is the mass emission flux (kg m-2 s-1) into that radius bin. +! +! !REVISION HISTORY: +! +! 30Mar2010 Colarco First crack! +! +!EOP +!------------------------------------------------------------------------- +CONTAINS +! +! !IROUTINE: SeasaltEmission - Master driver to compute the sea salt emissions +! +! !INTERFACE: +! + subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, & + memissions, nemissions, rc ) + +! !DESCRIPTION: Calculates the seasalt mass emission flux every timestep. +! The particular method (algorithm) used for the calculation is based +! on the value of "method" passed on input. Mostly these algorithms are +! a function of wind speed and particle size (nominally at 80% RH). +! Routine is called once for each size bin, passing in the edge radii +! "rLow" and "rUp" (in dry radius, units of um). Returned in the emission +! mass flux [kg m-2 s-1]. A sub-bin assumption is made to break (possibly) +! large size bins into a smaller space. +! +! !USES: + + implicit NONE + +! !INPUT PARAMETERS: + + real(kind=kind_phys), intent(in) :: rLow, rUp ! Dry particle bin edge radii [um] + real(kind=kind_phys), intent(in) :: w10m ! 10-m wind speed [m s-1] + real(kind=kind_phys), intent(in) :: ustar ! friction velocity [m s-1] + integer, intent(in) :: method ! Algorithm to use + +! !OUTPUT PARAMETERS: + + real(kind=kind_phys), intent(inout) :: memissions ! Mass Emissions Flux [kg m-2 s-1] + real(kind=kind_phys), intent(inout) :: nemissions ! Number Emissions Flux [# m-2 s-1] + integer, intent(out) :: rc ! Error return code: + ! 0 - all is well + ! 1 - +! !Local Variables + integer :: ir + real(kind=kind_phys) :: w ! Intermediary wind speed [m s-1] + real(kind=kind_phys) :: r, dr ! sub-bin radius spacing (dry, um) + real(kind=kind_phys) :: rwet, drwet ! sub-bin radius spacing (rh=80%, um) + real(kind=kind_phys) :: aFac, bFac, scalefac, rpow, exppow, wpow + + integer, parameter :: nr = 10 ! Number of (linear) sub-size bins + + character(len=*), parameter :: myname = 'SeasaltEmission' + +! Define the sub-bins (still in dry radius) + dr = (rUp - rLow)/nr + r = rLow + 0.5*dr + +! Loop over size bins + nemissions = 0. + memissions = 0. + + do ir = 1, nr + + rwet = r80fac * r + drwet = r80fac * dr + + select case(method) + + case(1) ! Gong 2003 + aFac = 4.7*(1.+30.*rwet)**(-0.017*rwet**(-1.44)) + bFac = (0.433-log10(rwet))/0.433 + scalefac = 1. + rpow = 3.45 + exppow = 1.607 + wpow = 3.41 + w = w10m + + case(2) ! Gong 1997 + aFac = 3. + bFac = (0.380-log10(rwet))/0.650 + scalefac = 1. + rpow = 1.05 + exppow = 1.19 + wpow = 3.41 + w = w10m + + case(3) ! GEOS5 2012 + aFac = 4.7*(1.+30.*rwet)**(-0.017*rwet**(-1.44)) + bFac = (0.433-log10(rwet))/0.433 + scalefac = 33.0e3 + rpow = 3.45 + exppow = 1.607 + wpow = 3.41 - 1. + w = ustar + + case default +! if(chem_comm_isroot()) print *, 'SeasaltEmission missing algorithm method' + rc = 1 + return + + end select + + +! Number emissions flux (# m-2 s-1) + nemissions = nemissions + SeasaltEmissionGong( rwet, drwet, w, scalefac, aFac, bFac, rpow, exppow, wpow ) +! Mass emissions flux (kg m-2 s-1) + scalefac = scalefac * 4./3.*pi*rhop*r**3.*1.e-18 + memissions = memissions + SeasaltEmissionGong( rwet, drwet, w, scalefac, aFac, bFac, rpow, exppow, wpow ) + + r = r + dr + + end do + + rc = 0 + + end subroutine SeasaltEmission + + +! Function to compute sea salt emissions following the Gong style +! parameterization. Functional form is from Gong 2003: +! dN/dr = scalefac * 1.373 * (w^wpow) * (r^-aFac) * (1+0.057*r^rpow) * 10^(exppow*exp(-bFac^2)) +! where r is the particle radius at 80% RH, dr is the size bin width at 80% RH, and w is the wind speed + + function SeasaltEmissionGong ( r, dr, w, scalefac, aFac, bFac, rpow, exppow, wpow ) + + real(kind=kind_phys), intent(in) :: r, dr ! Wet particle radius, bin width [um] + real(kind=kind_phys), intent(in) :: w ! Grid box mean wind speed [m s-1] (10-m or ustar wind) + real(kind=kind_phys), intent(in) :: scalefac, aFac, bFac, rpow, exppow, wpow + real(kind=kind_phys) :: SeasaltEmissionGong + +! Initialize + SeasaltEmissionGong = 0. + +! Particle size distribution function + SeasaltEmissionGong = scalefac * 1.373*r**(-aFac)*(1.+0.057*r**rpow) & + *10**(exppow*exp(-bFac**2.))*dr +! Apply wind speed function + SeasaltEmissionGong = w**wpow * SeasaltEmissionGong + + end function SeasaltEmissionGong + + + end module seas_ngac_mod From ec7a0429053325a6b0a6435085da0d90b41e32c4 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 8 Apr 2022 20:04:35 +0000 Subject: [PATCH 18/37] "update physics for Smoke" --- physics/GFS_DCNV_generic.F90 | 11 +++++-- physics/GFS_DCNV_generic.meta | 15 +++++++++ physics/GFS_SCNV_generic.F90 | 14 ++++++-- physics/GFS_SCNV_generic.meta | 15 +++++++++ physics/GFS_rrtmg_pre.F90 | 12 +++++++ physics/GFS_rrtmg_pre.meta | 23 +++++++++++++ physics/GFS_suite_interstitial.F90 | 16 +++++++-- physics/GFS_suite_interstitial.meta | 15 +++++++++ physics/module_MYNNPBL_wrapper.F90 | 51 +++++++++++++++-------------- physics/module_MYNNPBL_wrapper.meta | 30 +++++++++++++++++ physics/module_bl_mynn.F90 | 23 ++++++++++++- physics/module_mp_thompson.F90 | 5 ++- physics/mp_thompson.F90 | 4 ++- physics/mp_thompson.meta | 7 ++++ 14 files changed, 208 insertions(+), 33 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index e7dec5ca1..4c5e7f717 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -20,7 +20,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & - dtidx, index_of_process_dcnv, errmsg, errflg) + dtidx, index_of_process_dcnv,rrfs_smoke,dqdti, & + errmsg, errflg) use machine, only: kind_phys @@ -28,7 +29,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc - logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm + logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm, rrfs_smoke real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 @@ -37,6 +38,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q + ! dqdti only allocated if rrfs_smoke is .true. + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg logical, intent(in) :: cscnv, satmedmf, trans_trac, ras @@ -88,6 +91,10 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_q(:,:,ntqv) = gq0(:,:,ntqv) endif + if (rrfs_smoke) then + dqdti = zero + endif + end subroutine GFS_DCNV_generic_pre_run end module GFS_DCNV_generic_pre diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 47fb65d9a..1d7d87c17 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -247,6 +247,21 @@ dimensions = () type = integer intent = in +[rrfs_smoke] + standard_name = flag_for_rrfs_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index 58447f6bf..45fc3dd2d 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -99,7 +99,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & index_of_process_scnv, ntqv, flag_for_scnv_generic_tend, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & imfshalcnv, imfshalcnv_sas, imfshalcnv_samf, ntrac, & - cscnv, satmedmf, trans_trac, ras, errmsg, errflg) + cscnv, satmedmf, trans_trac, ras, rrfs_smoke, dqdti, errmsg, errflg) use machine, only: kind_phys @@ -107,13 +107,14 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & integer, intent(in) :: im, levs, nn, ntqv, nsamftrac integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend + logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend, rrfs_smoke real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t real(kind=kind_phys), dimension(:,:,:), intent(in) :: save_q, gq0 ! dtend only allocated if ldiag3d == .true. + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti real(kind=kind_phys), intent(inout) :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind, index_of_y_wind, index_of_process_scnv @@ -209,6 +210,15 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & endif endif + if (rrfs_smoke) then + do k=1,levs + do i=1,im + tem = (gq0_water_vapor(i,k)-save_qv(i,k)) * frain + dqdti(i,k) = dqdti(i,k) + tem + enddo + enddo + endif + end subroutine GFS_SCNV_generic_post_run end module GFS_SCNV_generic_post diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 5cbda127c..d1b4b452b 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -663,6 +663,21 @@ dimensions = () type = integer intent = in +[rrfs_smoke] + standard_name = flag_for_rrfs_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index db818c3b8..f29dbfd5e 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -36,6 +36,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & + aero_dir_fdb, smoke_ext, dust_ext, & spp_wts_rad, spp_rad, errmsg, errflg) use machine, only: kind_phys @@ -103,6 +104,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds + logical, intent(in) :: aero_dir_fdb + real(kind=kind_phys), dimension(:,:), intent(in) :: smoke_ext, dust_ext integer, intent(in) :: spp_rad real(kind_phys), intent(in) :: spp_wts_rad(:,:) @@ -601,6 +604,15 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo + if(aero_dir_fdb) then ! add smoke/dust extinctions + do k = 1, LMK + do i = 1, IM + ! 550nm (~18000/cm) + faersw1(i,k,10) = faersw1(i,k,10) + MAX(4.,smoke_ext(i,k) + dust_ext(i,k)) + enddo + enddo + endif + do j = 1,NBDLW do k = 1, LMK do i = 1, IM diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 1eac8a571..0e24b504a 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1082,6 +1082,29 @@ type = real kind = kind_phys intent = out +[aero_dir_fdb] + standard_name = rrfs_smoke_dust_rad_fdb_opt + long_name = flag for rrfs smoke dust rad feedback + units = flag + dimensions = () + type = logical + intent = in +[smoke_ext] + standard_name = smoke_ext + long_name = smoke optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dust_ext] + standard_name = dust_ext + long_name = dust optical extinction + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [spp_wts_rad] standard_name = spp_weights_for_radiation_scheme long_name = spp weights for radiation scheme diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 6963e94c3..591e27d88 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -701,7 +701,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, rrfs_smoke, dqdti, errmsg, errflg) use machine, only: kind_phys use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber @@ -714,7 +714,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - logical, intent(in) :: ltaerosol, convert_dry_rho + logical, intent(in) :: ltaerosol, convert_dry_rho, rrfs_smoke real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -734,6 +734,9 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(:,:), intent(in) :: spechum + ! dqdti may not be allocated + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti + character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -919,6 +922,15 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo endif ! end if_ntcw +! dqdt_v : instaneous moisture tendency (kg/kg/sec) + if (rrfs_smoke) then + do k=1,levs + do i=1,im + dqdti(i,k) = dqdti(i,k) * (1.0 / dtf) + enddo + enddo + endif + end subroutine GFS_suite_interstitial_4_run end module GFS_suite_interstitial_4 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 43b3d5efa..c994f1363 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1808,6 +1808,21 @@ dimensions = () type = integer intent = in +[rrfs_smoke] + standard_name = flag_for_rrfs_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index d9e53f9d3..c1d93536f 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -159,6 +159,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & + & chem3d, frp, mix_chem, fire_turb, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -182,7 +183,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !logical, intent(in) :: mix_chem, fire_turb !integer, intent(in) :: nchem, ndvel, kdvel !for testing only: - logical, parameter :: mix_chem=.false., fire_turb=.false. + !logical, parameter :: mix_chem=.false., fire_turb=.false. integer, parameter :: nchem=2, ndvel=2, kdvel=1 ! NAMELIST OPTIONS (INPUT): @@ -287,15 +288,17 @@ SUBROUTINE mynnedmf_wrapper_run( & !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 + real(kind_phys), dimension(:), intent(inout) :: frp + logical, intent(in) :: mix_chem, fire_turb + real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind=kind_phys), dimension(im) :: emis_ant_no + real(kind=kind_phys), dimension(im,ndvel) :: vdep !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 +! 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) :: & @@ -361,20 +364,20 @@ SUBROUTINE mynnedmf_wrapper_run( & endif !initialize arrays for test - qgrs_smoke_conc = 1.0 - qgrs_dust_conc = 1.0 - FRP = 0. + !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 (mix_chem) 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 + !if (mix_chem) 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) @@ -966,9 +969,9 @@ SUBROUTINE mynnedmf_wrapper_run( & deallocate(save_qke_adv) endif - if(allocated(chem3d))then - deallocate(chem3d) - endif +! if(allocated(chem3d))then +! deallocate(chem3d) +! endif CONTAINS diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 658c80100..d9c2ebf50 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1313,6 +1313,36 @@ dimensions = () type = integer intent = in +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + type = real + kind = kind_phys + intent = inout +[frp] + standard_name = frp_hourly + long_name = hourly frp + units = mw + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[mix_chem] + standard_name = rrfs_smoke_mynn_tracer_mixing + long_name = flag for rrfs smoke mynn tracer mixing + units = flag + dimensions = () + type = logical + intent = in +[fire_turb] + standard_name = rrfs_smoke_mynn_enh_vermix + long_name = flag for rrfs smoke mynn enh vermix + units = flag + dimensions = () + type = logical + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 292d5aa18..38dcc95df 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -5348,7 +5348,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & 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 :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing REAL, PARAMETER :: pblh_threshold = 250.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5362,6 +5362,27 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & rhoz(kts) =rho(kts) rhoinv(kts)=1./rho(kts) khdz(kts) =rhoz(kts)*dfh(kts) + + khdz_old = khdz(kts) + khdz_back = pblh * 0.15 / dz(kts) + !Enhance diffusion over fires + IF ( fire_turb ) THEN + IF ( pblh < pblh_threshold ) THEN + IF ( emis_ant_no > no_threshold ) THEN +! khdz(kts) = MAX(khdz(kts),khdz_back) + khdz(kts) = MAX(1.1*khdz(kts), sqrt((emis_ant_no / no_threshold))/dz(kts)*rhoz(kts)) ! JLS 12/21/21 + ENDIF + IF ( frp > frp_threshold ) THEN + !kmaxfire = ceiling(log(curr_frp)) ! JLS 12/21/21 - need to bring in curr_frp + kmaxfire = ceiling(log(frp)) + IF (k .le. kmaxfire) THEN ! JLS +! khdz(kts) = MAX(khdz(kts),khdz_back) + khdz(kts) = MAX(1.1*khdz(kts),((log(frp))**2.- 2.*log(frp)) / dz(kts)*rhoz(kts)) ! JLS 12/21/21 + ENDIF ! JLS + 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) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index c23b6d1d8..1cd5db703 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -968,7 +968,7 @@ END SUBROUTINE thompson_init !> @{ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa, nifa, nwfa2d, nifa2d, & - tt, th, pii, & + aero_ind_fdb, tt, th, pii, & p, w, dz, dt_in, dt_inner, & sedi_semi, decfl, & RAINNC, RAINNCV, & @@ -1023,6 +1023,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & nc, nwfa, nifa REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d + LOGICAL, OPTIONAL, INTENT(IN):: aero_ind_fdb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & re_cloud, re_ice, re_snow INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch @@ -1446,8 +1447,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & !.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol !.. number tendency (number per kg per second). if (is_aerosol_aware) then + if ( .not. aero_ind_fdb) then nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt + endif do k = kts, kte nc(i,k,j) = nc1d(k) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 7c76ea933..dd49d3c8c 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -300,7 +300,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & con_eps, convert_dry_rho, & spechum, qc, qr, qi, qs, qg, ni, nr, & is_aerosol_aware, nc, nwfa, nifa, & - nwfa2d, nifa2d, & + nwfa2d, nifa2d, aero_ind_fdb, & tgrs, prsl, phii, omega, & sedi_semi, decfl, dtp, dt_inner, & first_time_step, istep, nsteps, & @@ -339,6 +339,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), optional, intent(inout) :: nifa(:,:) real(kind_phys), optional, intent(in ) :: nwfa2d(:) real(kind_phys), optional, intent(in ) :: nifa2d(:) + logical, optional, intent(in ) :: aero_ind_fdb ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs(:,:) real(kind_phys), intent(in ) :: prsl(:,:) @@ -634,6 +635,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & if (is_aerosol_aware) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & + aero_ind_fdb=aero_ind_fdb, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, dt_inner=dt_inner, & sedi_semi=sedi_semi, decfl=decfl, & rainnc=rain_mp, rainncv=delta_rain_mp, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index a3bc20615..49bb15935 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -435,6 +435,13 @@ type = real kind = kind_phys intent = in +[aero_ind_fdb] + standard_name = rrfs_smoke_aero_ind_fdb_opt + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + intent = in [tgrs] standard_name = air_temperature_of_new_state long_name = model layer mean temperature From eb92feeb948715a31d6902ad143f2ebc0ec98203 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Mon, 11 Apr 2022 19:35:44 +0000 Subject: [PATCH 19/37] "update following Joe's comments for RRFS-Smoke" --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/module_MYNNPBL_wrapper.F90 | 33 +++-------------------------- physics/module_MYNNPBL_wrapper.meta | 14 ++++++++++++ physics/module_bl_mynn.F90 | 20 ----------------- 4 files changed, 18 insertions(+), 51 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index f29dbfd5e..a6cdc9eb2 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -608,7 +608,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do k = 1, LMK do i = 1, IM ! 550nm (~18000/cm) - faersw1(i,k,10) = faersw1(i,k,10) + MAX(4.,smoke_ext(i,k) + dust_ext(i,k)) + faersw1(i,k,10) = faersw1(i,k,10) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) enddo enddo endif diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index c1d93536f..8dd6c6532 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -159,7 +159,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, fire_turb, & + & chem3d, frp, mix_chem, fire_turb, nchem, ndvel, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: @@ -180,11 +180,8 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: cplflx !smoke/chem - !logical, intent(in) :: mix_chem, fire_turb - !integer, intent(in) :: nchem, ndvel, kdvel - !for testing only: - !logical, parameter :: mix_chem=.false., fire_turb=.false. - integer, parameter :: nchem=2, ndvel=2, kdvel=1 + integer, intent(in) :: nchem, ndvel + integer, parameter :: kdvel=1 ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & @@ -286,19 +283,11 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - ! real(kind=kind_phys), dimension(:,:), intent(inout), optional :: & - ! & qgrs_smoke_conc, qgrs_dust_conc real(kind_phys), dimension(:), intent(inout) :: frp logical, intent(in) :: mix_chem, fire_turb real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind=kind_phys), dimension(im) :: emis_ant_no real(kind=kind_phys), dimension(im,ndvel) :: vdep -!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) :: & @@ -364,20 +353,8 @@ SUBROUTINE mynnedmf_wrapper_run( & endif !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 (mix_chem) 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) @@ -969,10 +946,6 @@ SUBROUTINE mynnedmf_wrapper_run( & deallocate(save_qke_adv) endif -! if(allocated(chem3d))then -! deallocate(chem3d) -! endif - CONTAINS SUBROUTINE dtend_helper(itracer,field,mult) diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index d9c2ebf50..217271110 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1343,6 +1343,20 @@ dimensions = () type = logical intent = in +[nchem] + standard_name = number_of_chemical_species_vertically_mixed + long_name = number of chemical vertically mixed + units = count + dimensions = () + type = integer + intent = in +[ndvel] + standard_name = number_of_chemical_species_deposited + long_name = number of chemical pbl deposited + units = count + dimensions = () + type = integer + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 38dcc95df..f264cdd3c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -5363,26 +5363,6 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & rhoinv(kts)=1./rho(kts) khdz(kts) =rhoz(kts)*dfh(kts) - khdz_old = khdz(kts) - khdz_back = pblh * 0.15 / dz(kts) - !Enhance diffusion over fires - IF ( fire_turb ) THEN - IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > no_threshold ) THEN -! khdz(kts) = MAX(khdz(kts),khdz_back) - khdz(kts) = MAX(1.1*khdz(kts), sqrt((emis_ant_no / no_threshold))/dz(kts)*rhoz(kts)) ! JLS 12/21/21 - ENDIF - IF ( frp > frp_threshold ) THEN - !kmaxfire = ceiling(log(curr_frp)) ! JLS 12/21/21 - need to bring in curr_frp - kmaxfire = ceiling(log(frp)) - IF (k .le. kmaxfire) THEN ! JLS -! khdz(kts) = MAX(khdz(kts),khdz_back) - khdz(kts) = MAX(1.1*khdz(kts),((log(frp))**2.- 2.*log(frp)) / dz(kts)*rhoz(kts)) ! JLS 12/21/21 - ENDIF ! JLS - 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) From 8b4ee36339a23c2a0b3bca2afcde500adf2acd75 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Thu, 14 Apr 2022 14:40:46 +0000 Subject: [PATCH 20/37] "restore to gsl/develop" --- physics/GFS_DCNV_generic.F90 | 11 ++--------- physics/GFS_DCNV_generic.meta | 15 --------------- physics/GFS_SCNV_generic.F90 | 14 ++------------ physics/GFS_SCNV_generic.meta | 15 --------------- physics/GFS_suite_interstitial.F90 | 16 ++-------------- physics/GFS_suite_interstitial.meta | 15 --------------- 6 files changed, 6 insertions(+), 80 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index 4c5e7f717..e7dec5ca1 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -20,8 +20,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & - dtidx, index_of_process_dcnv,rrfs_smoke,dqdti, & - errmsg, errflg) + dtidx, index_of_process_dcnv, errmsg, errflg) use machine, only: kind_phys @@ -29,7 +28,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc - logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm, rrfs_smoke + logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 @@ -38,8 +37,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - ! dqdti only allocated if rrfs_smoke is .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg logical, intent(in) :: cscnv, satmedmf, trans_trac, ras @@ -91,10 +88,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_q(:,:,ntqv) = gq0(:,:,ntqv) endif - if (rrfs_smoke) then - dqdti = zero - endif - end subroutine GFS_DCNV_generic_pre_run end module GFS_DCNV_generic_pre diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 1d7d87c17..47fb65d9a 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -247,21 +247,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke] - standard_name = flag_for_rrfs_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index 45fc3dd2d..58447f6bf 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -99,7 +99,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & index_of_process_scnv, ntqv, flag_for_scnv_generic_tend, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & imfshalcnv, imfshalcnv_sas, imfshalcnv_samf, ntrac, & - cscnv, satmedmf, trans_trac, ras, rrfs_smoke, dqdti, errmsg, errflg) + cscnv, satmedmf, trans_trac, ras, errmsg, errflg) use machine, only: kind_phys @@ -107,14 +107,13 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & integer, intent(in) :: im, levs, nn, ntqv, nsamftrac integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend, rrfs_smoke + logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t real(kind=kind_phys), dimension(:,:,:), intent(in) :: save_q, gq0 ! dtend only allocated if ldiag3d == .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti real(kind=kind_phys), intent(inout) :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind, index_of_y_wind, index_of_process_scnv @@ -210,15 +209,6 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & endif endif - if (rrfs_smoke) then - do k=1,levs - do i=1,im - tem = (gq0_water_vapor(i,k)-save_qv(i,k)) * frain - dqdti(i,k) = dqdti(i,k) + tem - enddo - enddo - endif - end subroutine GFS_SCNV_generic_post_run end module GFS_SCNV_generic_post diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index d1b4b452b..5cbda127c 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -663,21 +663,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke] - standard_name = flag_for_rrfs_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 591e27d88..6963e94c3 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -701,7 +701,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & - qdiag3d, save_lnc, save_inc, ntk, ntke, rrfs_smoke, dqdti, errmsg, errflg) + qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) use machine, only: kind_phys use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber @@ -714,7 +714,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - logical, intent(in) :: ltaerosol, convert_dry_rho, rrfs_smoke + logical, intent(in) :: ltaerosol, convert_dry_rho real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -734,9 +734,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(:,:), intent(in) :: spechum - ! dqdti may not be allocated - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti - character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -922,15 +919,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo endif ! end if_ntcw -! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (rrfs_smoke) then - do k=1,levs - do i=1,im - dqdti(i,k) = dqdti(i,k) * (1.0 / dtf) - enddo - enddo - endif - end subroutine GFS_suite_interstitial_4_run end module GFS_suite_interstitial_4 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index c994f1363..43b3d5efa 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1808,21 +1808,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke] - standard_name = flag_for_rrfs_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From d5c8c954f574263ce89996be11d5c54e8f4595b1 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 22 Apr 2022 19:29:47 +0000 Subject: [PATCH 21/37] Add haiqin to CODEOWNERS for smoke code --- CODEOWNERS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CODEOWNERS b/CODEOWNERS index c845e7f97..cf7a886aa 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -11,6 +11,8 @@ # https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 # (Internal NOAA document.) +smoke/* @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA + physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA From df54eaa9b53f7b45cf0c0ae3f7ad69a8bc2c30b6 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Sat, 23 Apr 2022 22:51:46 +0000 Subject: [PATCH 22/37] corrections to merge --- physics/GFS_surface_composites_pre.F90 | 5 ++--- physics/GFS_surface_composites_pre.meta | 14 -------------- physics/mynnpbl_wrapper.F90 | 5 ++--- 3 files changed, 4 insertions(+), 20 deletions(-) diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 8e130b229..6139f80dd 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -21,7 +21,7 @@ module GFS_surface_composites_pre !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_cold_start, lkm, frac_grid, & + subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, lkm, frac_grid, & flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & @@ -35,9 +35,8 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, flag_init, lsm_co implicit none ! Interface variables - integer, intent(in ) :: im, lkm, kdt integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc - logical, intent(in ) :: flag_init, lsm_cold_start, frac_grid, cplflx, cplice, cplwav2atm + logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index 15259e8b9..e6b437471 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -30,20 +30,6 @@ type = real kind = kind_phys intent = in -[lsm_cold_start] - standard_name = do_lsm_cold_start - long_name = flag to signify LSM is cold-started - 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 [lkm] standard_name = control_for_lake_surface_scheme long_name = flag for lake surface model diff --git a/physics/mynnpbl_wrapper.F90 b/physics/mynnpbl_wrapper.F90 index f2858042d..7625b8e9e 100644 --- a/physics/mynnpbl_wrapper.F90 +++ b/physics/mynnpbl_wrapper.F90 @@ -261,12 +261,11 @@ SUBROUTINE mynnedmf_wrapper_run( & & sub_thl,sub_sqv,det_thl,det_sqv 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_water_vapor, & - & qgrs_liquid_cloud, & - & qgrs_ice_cloud, & & qgrs_cloud_droplet_num_conc, & & qgrs_cloud_ice_num_conc, & & qgrs_ozone, & From 89c0c11fbb9559a348ee6dbd949061676e4ee43e Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 16:39:53 +0000 Subject: [PATCH 23/37] Correct issues found by reviewers --- physics/GFS_debug.F90 | 4 +- physics/GFS_rrtmg_pre.meta | 8 +-- physics/GFS_surface_composites_pre.F90 | 3 +- physics/GFS_surface_composites_pre.meta | 16 ------ physics/bl_mynn_common.f90 | 67 ++++++++++++++++++++++++ physics/module_bl_mynn.F90 | 68 ------------------------- physics/module_sf_ruclsm.F90 | 15 ------ physics/mynnpbl_wrapper.meta | 2 +- smoke/rrfs_smoke_wrapper.meta | 8 +-- 9 files changed, 79 insertions(+), 112 deletions(-) create mode 100644 physics/bl_mynn_common.f90 diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index d5ffeaa63..e4278fc45 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -593,9 +593,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvb' , Tbd%acvb) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvt' , Tbd%acvt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%hpbl' , Tbd%hpbl) - if (Model%imfdeepcnv .ge. 0 .or. Model%imfshalcnv .ge. 0) then + if(Model%imfdeepcnv>0 .or. Model%imfshalcnv>0) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ud_mf' , Tbd%ud_mf) - end if + endif if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtdtnp' , Tbd%dtdtnp) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtotprcp' , Tbd%dtotprcp) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index a1839e001..154cb2fab 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1202,16 +1202,16 @@ type = logical intent = in [smoke_ext] - standard_name = smoke_ext - long_name = smoke optical extinction + standard_name = extinction_coefficient_in_air_due_to_smoke + long_name = extinction coefficient in air due to smoke units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in [dust_ext] - standard_name = dust_ext - long_name = dust optical extinction + standard_name = extinction_coefficient_in_air_due_to_dust + long_name = extinction coefficient in air due to dust units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 6139f80dd..734f1965b 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -21,7 +21,7 @@ module GFS_surface_composites_pre !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, lkm, frac_grid, & + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, & flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & @@ -39,7 +39,6 @@ subroutine GFS_surface_composites_pre_run (im, xlat_d, xlon_d, lkm, frac_grid, logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet - real(kind=kind_phys), dimension(:), intent(in ) :: xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index e6b437471..e87af3e28 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -14,22 +14,6 @@ dimensions = () type = integer intent = in -[xlat_d] - standard_name = latitude_in_degree - long_name = latitude in degree north - units = degree_north - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xlon_d] - standard_name = longitude_in_degree - long_name = longitude in degree east - units = degree_east - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [lkm] standard_name = control_for_lake_surface_scheme long_name = flag for lake surface model diff --git a/physics/bl_mynn_common.f90 b/physics/bl_mynn_common.f90 new file mode 100644 index 000000000..7923bbf8b --- /dev/null +++ b/physics/bl_mynn_common.f90 @@ -0,0 +1,67 @@ +!>\file bl_mynn_common.f90 +!! 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: + module bl_mynn_common + +!------------------------------------------ +! +!------------------------------------------ + +! 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 diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index f264cdd3c..409fb3740 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -236,74 +236,6 @@ ! Many of these changes are now documented in references listed above. !==================================================================== - 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 - -!================================================================== - MODULE module_bl_mynn use bl_mynn_common,only: & diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 01e9c1100..0cf820303 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2581,21 +2581,6 @@ SUBROUTINE SOIL (debug_print, & ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif alfa=1. -! field capacity -! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation -! when soil moisture is below field capacity. [Lee and Pielke, 1992] -! This formulation agrees with obsevations when top layer is < 2 cm thick. -! Soilres = 1 for snow, glaciers and wetland. -! fc=ref - suggested in the paper -! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change -! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct -! evaporation, effects sparsely vegetated areas--> cooler during the day -! fc=max(qmin,ref*0.25) ! -! For now we'll go back to ref*0.5 -! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct -! evaporation. Therefore , it is replaced with ref*0.7. - !fc=max(qmin,ref*0.5) - !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then diff --git a/physics/mynnpbl_wrapper.meta b/physics/mynnpbl_wrapper.meta index 4b52c6e8d..4377ffce8 100644 --- a/physics/mynnpbl_wrapper.meta +++ b/physics/mynnpbl_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnedmf_wrapper type = scheme - dependencies = machine.F,module_bl_mynn.F90,physcons.F90 + dependencies = machine.F,module_bl_mynn.F90,physcons.F90,bl_mynn_common.f90 ######################################################################## [ccpp-arg-table] diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index 867550f50..c96a8b17a 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -530,16 +530,16 @@ kind = kind_phys intent = out [smoke_ext] - standard_name = smoke_ext - long_name = smoke optical extinction + standard_name = extinction_coefficient_in_air_due_to_smoke + long_name = extinction coefficient in air due to smoke units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out [dust_ext] - standard_name = dust_ext - long_name = dust optical extinction + standard_name = extinction_coefficient_in_air_due_to_dust + long_name = extinction coefficient in air due to dust units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real From 86022b3104278c7f0df217293dbaba6f43cbeff2 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 17:42:59 +0000 Subject: [PATCH 24/37] Rename mynnpbl to mynnedmf --- physics/GFS_debug.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 1 + physics/{mynnpbl_wrapper.F90 => mynnedmf_wrapper.F90} | 2 +- physics/{mynnpbl_wrapper.meta => mynnedmf_wrapper.meta} | 4 ++-- 4 files changed, 5 insertions(+), 4 deletions(-) rename physics/{mynnpbl_wrapper.F90 => mynnedmf_wrapper.F90} (99%) rename physics/{mynnpbl_wrapper.meta => mynnedmf_wrapper.meta} (99%) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index e4278fc45..ef1a8003f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -726,7 +726,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, end if call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dkt ', Diag%dkt) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dku ', Diag%dku) - ! CCPP/MYNNPBL only + ! CCPP/MYNNEDMF only if (Model%do_mynnedmf) then if (Model%bl_mynn_output .ne. 0) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_a ', Diag%edmf_a) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index f1b0027ac..57261ef18 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -619,6 +619,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo + !> Aerosol direct feedback effect by smoke and dust if(aero_dir_fdb) then ! add smoke/dust extinctions do k = 1, LMK do i = 1, IM diff --git a/physics/mynnpbl_wrapper.F90 b/physics/mynnedmf_wrapper.F90 similarity index 99% rename from physics/mynnpbl_wrapper.F90 rename to physics/mynnedmf_wrapper.F90 index 7625b8e9e..744a07e51 100644 --- a/physics/mynnpbl_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -1,4 +1,4 @@ -!> \file MYNNPBL_wrapper.F90 +!> \file mynnedmf_wrapper.F90 !! This file contains all of the code related to running the MYNN !! eddy-diffusivity mass-flux scheme. diff --git a/physics/mynnpbl_wrapper.meta b/physics/mynnedmf_wrapper.meta similarity index 99% rename from physics/mynnpbl_wrapper.meta rename to physics/mynnedmf_wrapper.meta index 4377ffce8..7fbb85311 100644 --- a/physics/mynnpbl_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -781,7 +781,7 @@ kind = kind_phys intent = inout [exch_h] - standard_name = atmosphere_heat_diffusivity_for_mynnpbl + standard_name = atmosphere_heat_diffusivity_for_mynnedmf long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) @@ -789,7 +789,7 @@ kind = kind_phys intent = out [exch_m] - standard_name = atmosphere_momentum_diffusivity_for_mynnpbl + standard_name = atmosphere_momentum_diffusivity_for_mynnedmf long_name = diffusivity for momentum for MYNN PBL (defined for all mass levels) units = m2 s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) From 900e2c3e1f3a4aa82c35ad99f9456edd56c6599c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Apr 2022 21:28:30 +0000 Subject: [PATCH 25/37] Remove some empty _init and _finalize routines and update a comment in sgscloud_radpre --- physics/sgscloud_radpre.F90 | 11 +++++++---- smoke/rrfs_smoke_lsdep_wrapper.F90 | 14 +------------- smoke/rrfs_smoke_lsdep_wrapper.meta | 10 ---------- smoke/rrfs_smoke_postpbl.F90 | 14 +------------- smoke/rrfs_smoke_postpbl.meta | 10 ---------- smoke/rrfs_smoke_wrapper.F90 | 14 +------------- smoke/rrfs_smoke_wrapper.meta | 10 ---------- 7 files changed, 10 insertions(+), 73 deletions(-) diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index 1b63c5471..6567a331b 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -23,10 +23,13 @@ end subroutine sgscloud_radpre_init subroutine sgscloud_radpre_finalize () end subroutine sgscloud_radpre_finalize -!> This interstitial code adds the subgrid clouds to the resolved-scale clouds -!! if there is no resolved-scale clouds in that particular grid box. It can also -!! specify a cloud fraction for resolved-scale clouds, using Xu-Randall (1996), -!! if desired. +!> This interstitial code adds the subgrid clouds to the resolved-scale clouds +!! if there is no resolved-scale clouds in that particular grid box. It can also +!! specify a cloud fraction for resolved-scale clouds as is done currently when +!! using MYNN-EDMF. For clouds coming from the convection schemes (in this case +!! only used by GF scheme), two cloud fraction options are available: +!! Xu-Randall (XR1996) or Chaboureau and Bechtold (CB2005), chosen by the +!! switch "conv_cf_opt" = 0: CB2005, 1: XR1996. !> \section arg_table_sgscloud_radpre_run Argument Table !! \htmlinclude sgscloud_radpre_run.html !! diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index 8625fe844..d4aa1323b 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -15,22 +15,10 @@ module rrfs_smoke_lsdep_wrapper private - public :: rrfs_smoke_lsdep_wrapper_init, rrfs_smoke_lsdep_wrapper_run, rrfs_smoke_lsdep_wrapper_finalize + public :: rrfs_smoke_lsdep_wrapper_run contains -!> \brief Brief description of the subroutine -!! - subroutine rrfs_smoke_lsdep_wrapper_init() - end subroutine rrfs_smoke_lsdep_wrapper_init - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_rrfs_smoke_lsdep_wrapper_finalize Argument Table -!! - subroutine rrfs_smoke_lsdep_wrapper_finalize() - end subroutine rrfs_smoke_lsdep_wrapper_finalize - !> \defgroup gsd_chem_group GSD Chem driver Module !! This is the gsd chemistry !>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/smoke/rrfs_smoke_lsdep_wrapper.meta index 7766ab2c4..8a9ff5462 100755 --- a/smoke/rrfs_smoke_lsdep_wrapper.meta +++ b/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -3,16 +3,6 @@ type = scheme dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_lsdep_wrapper_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_lsdep_wrapper_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = rrfs_smoke_lsdep_wrapper_run diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 index 02ed273ae..e58f3d49b 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -11,22 +11,10 @@ module rrfs_smoke_postpbl private - public :: rrfs_smoke_postpbl_init, rrfs_smoke_postpbl_run, rrfs_smoke_postpbl_finalize + public :: rrfs_smoke_postpbl_run contains -!> \brief Brief description of the subroutine -!! - subroutine rrfs_smoke_postpbl_init() - end subroutine rrfs_smoke_postpbl_init - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_rrfs_smoke_postpbl_finalize Argument Table -!! - subroutine rrfs_smoke_postpbl_finalize() - end subroutine rrfs_smoke_postpbl_finalize - !> \defgroup gsd_chem_group GSD Chem emission driver Module !! This is the gsd chemistry !>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module diff --git a/smoke/rrfs_smoke_postpbl.meta b/smoke/rrfs_smoke_postpbl.meta index e9597adc8..45ca60cb4 100755 --- a/smoke/rrfs_smoke_postpbl.meta +++ b/smoke/rrfs_smoke_postpbl.meta @@ -3,16 +3,6 @@ type = scheme dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = rrfs_smoke_wrapper_run diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index 7b2cda56b..105594cb5 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -20,22 +20,10 @@ module rrfs_smoke_wrapper private - public :: rrfs_smoke_wrapper_init, rrfs_smoke_wrapper_run, rrfs_smoke_wrapper_finalize + public :: rrfs_smoke_wrapper_run contains -!> \brief Brief description of the subroutine -!! - subroutine rrfs_smoke_wrapper_init() - end subroutine rrfs_smoke_wrapper_init - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_rrfs_smoke_wrapper_finalize Argument Table -!! - subroutine rrfs_smoke_wrapper_finalize() - end subroutine rrfs_smoke_wrapper_finalize - !> \defgroup gsd_chem_group GSD Chem emission driver Module !! This is the gsd chemistry !>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index c96a8b17a..709ea00d1 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -3,16 +3,6 @@ type = scheme dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_wrapper_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = rrfs_smoke_wrapper_run From 3fba412336314ac008ed70a45d85e17024dd7cef Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 28 Apr 2022 23:29:39 +0000 Subject: [PATCH 26/37] Add \file to smoke files --- smoke/dep_dry_gocart_mod.F90 | 4 ++++ smoke/dep_dry_mod.F90 | 3 +++ smoke/dep_simple_mod.F90 | 3 +++ smoke/dep_vertmx_mod.F90 | 3 +++ smoke/dep_wet_ls_mod.F90 | 3 +++ smoke/dust_data_mod.F90 | 3 +++ smoke/dust_fengsha_mod.F90 | 3 +++ smoke/module_add_emiss_burn.F90 | 3 +++ smoke/module_plumerise1.F90 | 3 +++ smoke/module_smoke_plumerise.F90 | 3 +++ smoke/module_zero_plumegen_coms.F90 | 3 +++ smoke/plume_data_mod.F90 | 3 +++ smoke/rrfs_smoke_config.F90 | 4 +++- smoke/rrfs_smoke_data.F90 | 3 +++ smoke/rrfs_smoke_lsdep_wrapper.F90 | 2 -- smoke/rrfs_smoke_postpbl.F90 | 2 -- smoke/rrfs_smoke_wrapper.F90 | 2 -- smoke/seas_data_mod.F90 | 3 +++ smoke/seas_mod.F90 | 3 +++ smoke/seas_ngac_mod.F90 | 3 +++ 20 files changed, 52 insertions(+), 7 deletions(-) diff --git a/smoke/dep_dry_gocart_mod.F90 b/smoke/dep_dry_gocart_mod.F90 index 6e15f2e57..9fb5edfd1 100755 --- a/smoke/dep_dry_gocart_mod.F90 +++ b/smoke/dep_dry_gocart_mod.F90 @@ -1,3 +1,7 @@ +!>\file dep_dry_gocart_mod.F90 +!! This file is GOCART dry deposition module to calculate the dry deposition +!! velocities of smoke and dust. + module dep_dry_gocart_mod use machine , only : kind_phys diff --git a/smoke/dep_dry_mod.F90 b/smoke/dep_dry_mod.F90 index 140db6002..9520d2897 100755 --- a/smoke/dep_dry_mod.F90 +++ b/smoke/dep_dry_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_dry_mod.F90 +!! This file is for the dry depostion driver. + module dep_dry_mod use machine , only : kind_phys diff --git a/smoke/dep_simple_mod.F90 b/smoke/dep_simple_mod.F90 index 9751b19a6..37a8189b5 100755 --- a/smoke/dep_simple_mod.F90 +++ b/smoke/dep_simple_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_simple_mod.F90 +!! This file contains the Wesely dry deposition module. + module dep_simple_mod use rrfs_smoke_data diff --git a/smoke/dep_vertmx_mod.F90 b/smoke/dep_vertmx_mod.F90 index 5933af271..d56b1b87e 100755 --- a/smoke/dep_vertmx_mod.F90 +++ b/smoke/dep_vertmx_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_vertmx_mod.F90 +!! This file calculates change in time of phi due to vertical mixing and dry deposition. + MODULE dep_vertmx_mod use rrfs_smoke_data use machine , only : kind_phys diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 index bfbe275f2..23ceb803e 100755 --- a/smoke/dep_wet_ls_mod.F90 +++ b/smoke/dep_wet_ls_mod.F90 @@ -1,3 +1,6 @@ +!>\file dep_wet_ls_mod.F90 +!! This file contains aerosol wet deposition module. + module dep_wet_ls_mod use rrfs_smoke_data use machine , only : kind_phys diff --git a/smoke/dust_data_mod.F90 b/smoke/dust_data_mod.F90 index 33767701b..9e9713e22 100755 --- a/smoke/dust_data_mod.F90 +++ b/smoke/dust_data_mod.F90 @@ -1,3 +1,6 @@ +!>\file dust_data_mod.F90 +!! This file contains the data for the dust flux schemes. + module dust_data_mod use rrfs_smoke_data diff --git a/smoke/dust_fengsha_mod.F90 b/smoke/dust_fengsha_mod.F90 index c43719386..fbf87aa56 100755 --- a/smoke/dust_fengsha_mod.F90 +++ b/smoke/dust_fengsha_mod.F90 @@ -1,3 +1,6 @@ +!>\file dust_fengsha_mod.F90 +!! This file contains the FENGSHA dust scheme. + module dust_fengsha_mod ! ! This module developed by Barry Baker (NOAA ARL) diff --git a/smoke/module_add_emiss_burn.F90 b/smoke/module_add_emiss_burn.F90 index 5d5e63b21..da35535f7 100755 --- a/smoke/module_add_emiss_burn.F90 +++ b/smoke/module_add_emiss_burn.F90 @@ -1,3 +1,6 @@ +!>\file module_add_emiss_burn.F90 +!! This file adds the biomass burning emissions to the smoke field. + module module_add_emiss_burn !RAR: significantly modified for the new BB emissions use machine , only : kind_phys diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index ea2c4e3f7..f3c756b7e 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -1,3 +1,6 @@ +!>\file module_plumerise1.F90 +!! This file is the fire plume rise driver. + module module_plumerise1 use rrfs_smoke_data diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 index f31759404..a9535f8b1 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/smoke/module_smoke_plumerise.F90 @@ -1,3 +1,6 @@ +!>\file module_smoke_plumerise.F90 +!! This file contains the fire plume rise module. + !------------------------------------------------------------------------- !- 12 April 2016 !- Implementing the fire radiative power (FRP) methodology for biomass burning diff --git a/smoke/module_zero_plumegen_coms.F90 b/smoke/module_zero_plumegen_coms.F90 index d00554753..622d6a813 100755 --- a/smoke/module_zero_plumegen_coms.F90 +++ b/smoke/module_zero_plumegen_coms.F90 @@ -1,3 +1,6 @@ +!>\file module_zero_plumegen_coms.F90 +!! This module initilizes variables for the fire plume rise scheme. + module module_zero_plumegen_coms use machine , only : kind_phys diff --git a/smoke/plume_data_mod.F90 b/smoke/plume_data_mod.F90 index ce89dc4fd..3d4b21c37 100755 --- a/smoke/plume_data_mod.F90 +++ b/smoke/plume_data_mod.F90 @@ -1,3 +1,6 @@ +!>\file plume_data_mod.F90 +!! This file contains data for the fire plume rise module. + module plume_data_mod use machine , only : kind_phys diff --git a/smoke/rrfs_smoke_config.F90 b/smoke/rrfs_smoke_config.F90 index f3cdd13c9..43b3aee14 100755 --- a/smoke/rrfs_smoke_config.F90 +++ b/smoke/rrfs_smoke_config.F90 @@ -1,8 +1,10 @@ +!>\file rrfs_smoke_config.F90 +!! This file contains the configuration for RRFS-Smoke. ! ! Haiqin.Li@noaa.gov ! 06/2021 ! constant parameters and chemistry configurations and tracers -! (This will be splited into three subroutine for configuration, constant and tracers later) +! (This will be splited into three subroutines for configuration, constant and tracers later) ! 06/2021 move configuration into chem nml ! module rrfs_smoke_config diff --git a/smoke/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 index b5dbf5199..f1d11960a 100755 --- a/smoke/rrfs_smoke_data.F90 +++ b/smoke/rrfs_smoke_data.F90 @@ -1,3 +1,6 @@ +!>\file rrfs_smoke_data.F90 +!! This file contains data for the RRFS-Smoke modules. + module rrfs_smoke_data use machine , only : kind_phys implicit none diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index d4aa1323b..d64866f41 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -19,8 +19,6 @@ module rrfs_smoke_lsdep_wrapper contains -!> \defgroup gsd_chem_group GSD Chem driver Module -!! This is the gsd chemistry !>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module !> \ingroup gsd_chem_group !! This is the GSD Chem driver Module diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 index e58f3d49b..b9d61d42b 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -15,8 +15,6 @@ module rrfs_smoke_postpbl contains -!> \defgroup gsd_chem_group GSD Chem emission driver Module -!! This is the gsd chemistry !>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module !> \ingroup gsd_chem_group !! This is the GSD Chem emission driver Module diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index 105594cb5..a179553b6 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -24,8 +24,6 @@ module rrfs_smoke_wrapper contains -!> \defgroup gsd_chem_group GSD Chem emission driver Module -!! This is the gsd chemistry !>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module !> \ingroup gsd_chem_group !! This is the GSD Chem emission driver Module diff --git a/smoke/seas_data_mod.F90 b/smoke/seas_data_mod.F90 index 6602d58a2..a6f451c39 100755 --- a/smoke/seas_data_mod.F90 +++ b/smoke/seas_data_mod.F90 @@ -1,3 +1,6 @@ +!>\file seas_data_mod.F90 +!! This file contains data for the sea salt emission modules. + module seas_data_mod use machine , only : kind_phys diff --git a/smoke/seas_mod.F90 b/smoke/seas_mod.F90 index a610884d6..78bcef5be 100755 --- a/smoke/seas_mod.F90 +++ b/smoke/seas_mod.F90 @@ -1,3 +1,6 @@ +!>\file seas_mod.F90 +!! This file contains the sea salt emission module. + module seas_mod use machine , only : kind_phys diff --git a/smoke/seas_ngac_mod.F90 b/smoke/seas_ngac_mod.F90 index 73605ecc1..411635db2 100755 --- a/smoke/seas_ngac_mod.F90 +++ b/smoke/seas_ngac_mod.F90 @@ -1,3 +1,6 @@ +!>\file seas_ngac_mod.F90 +!! This file contains the ngac sea-salt module. + !------------------------------------------------------------------------- ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! ! Adapted by NOAA/GSD/ESRL ! From 5c6243d5c47dd12e392e9afa9f954a771625cd51 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 4 May 2022 19:57:04 +0000 Subject: [PATCH 27/37] adding bug fix from jili dong and removing U* averaging --- physics/module_sf_mynn.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 31335d3a9..f82597b15 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -848,8 +848,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: - TH1D(I)=T1D(I)*THCON(I) !(Theta, K) - TC1D(I)=T1D(I)-273.15 !(T, Celsius) + TH1D(I)=T1D(I)**(100000./P1D(I))**ROVCP !(Theta, K) + TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO DO I=its,ite @@ -859,7 +859,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO DO I=its,ite - RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver + RHO1D(I)=P1D(I)/(R*TV1D(I)) !now using value calculated in sfc driver ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level GOVRTH(I)=G/TH1D(I) @@ -1724,9 +1724,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(I)) THEN ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE OLDUST = UST_wat(I) - UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) + !UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) !NON-AVERAGED: - !UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) + UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) stress_wat(i)=ust_wat(i)**2 ! Compute u* without vconv for use in HFX calc when isftcflx > 0 @@ -1891,7 +1891,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_lnd(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_lnd(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_lnd(I)*KARMAN/PSIT_lnd(I)*(THSK_lnd(I)-TH1D(i)) HFX(I)=MAX(HFX(I),-250.) ! BWG, 2020-06-17: Mod next 2 lines for fractional HFLX_lnd(I)=HFX(I)/(RHO1D(I)*cpm(I)) @@ -1935,7 +1936,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_wat(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_wat(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_wat(I)*KARMAN/PSIT_wat(I)*(THSK_wat(I)-TH1D(i)) IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX.NE.0 ) THEN ! AHW: add dissipative heating term @@ -1982,7 +1984,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------- ! COMPUTE SURFACE HEAT FLUX: !---------------------------------- - HFX(I)=FLHC(I)*(THSK_ice(I)-TH1D(I)) + !HFX(I)=FLHC(I)*(THSK_ice(I)-TH1D(I)) + HFX(I)=RHO1D(I)*CPM(I)*KARMAN*WSPD(i)/PSIX_ice(I)*KARMAN/PSIT_ice(I)*(THSK_ice(I)-TH1D(i)) HFX(I)=MAX(HFX(I),-250.) ! BWG, 2020-06-17: Mod next 2 lines for fractional HFLX_ice(I)=HFX(I)/(RHO1D(I)*cpm(I)) From bb45b2b08f87c2737937e7a3ef835033715aec72 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 16:52:50 +0000 Subject: [PATCH 28/37] adding bug fix from jili dong and removing U* averaging --- physics/module_sf_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index f82597b15..da058139e 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -849,7 +849,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: TH1D(I)=T1D(I)**(100000./P1D(I))**ROVCP !(Theta, K) - TC1D(I)=T1D(I)-273.15 !(T, Celsius) + TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO DO I=its,ite From 3b7423b3d97f45a901e077518b0750d6473b03af Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 16:47:23 +0000 Subject: [PATCH 29/37] Remove some commented-out code. --- physics/cu_gf_driver.F90 | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index a9cecb5ce..a87473958 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -39,26 +39,6 @@ subroutine cu_gf_driver_init(imfshalcnv, imfshalcnv_gf, imfdeepcnv, & errmsg = '' errflg = 0 - ! DH* temporary - ! if (mpirank==mpiroot) then - ! write(0,*) ' ----------------------------------------------------------'//& - ! '-------------------------------------------------------------------' - ! write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is'//& - ! ' currently under development, use at your own risk --- WARNING ---' - ! write(0,*) ' --------------------------------------------------------------------'//& - ! '---------------------------------------------------------' - ! end if - ! *DH temporary - - ! ! Consistency checks - ! if (.not. (imfshalcnv == imfshalcnv_gf .or. & - ! & imfdeepcnv == imfdeepcnv_gf)) then - ! write(errmsg,'(*(a))') 'Logic error: namelist choice of', & - ! & ' convection is different from Grell-Freitas scheme' - ! errflg = 1 - ! return - ! end if - end subroutine cu_gf_driver_init subroutine cu_gf_driver_finalize() From cd410130fcf0de0ea68c7dd98e0ecd0ccb85855f Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 17:44:02 +0000 Subject: [PATCH 30/37] Turn rrtmg smoke band 10 into a model namelist variable --- physics/GFS_rrtmg_pre.F90 | 7 ++++--- physics/GFS_rrtmg_pre.meta | 7 +++++++ 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 57261ef18..106007cdc 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -41,7 +41,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, errmsg, errflg) + spp_wts_rad, spp_rad, rrfs_smoke_band, errmsg, errflg) use machine, only: kind_phys @@ -109,7 +109,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & iovr_exprand, & ! Flag for exponential-random cloud overlap method idcor_con, & idcor_hogan, & - idcor_oreopoulos + idcor_oreopoulos, & + rrfs_smoke_band ! Band number for rrfs-smoke dust and smoke character(len=3), dimension(:), intent(in) :: lndp_var_list @@ -624,7 +625,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do k = 1, LMK do i = 1, IM ! 550nm (~18000/cm) - faersw1(i,k,10) = faersw1(i,k,10) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) + faersw1(i,k,rrfs_smoke_band) = faersw1(i,k,rrfs_smoke_band) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) enddo enddo endif diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 154cb2fab..695ae65ef 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1232,6 +1232,13 @@ dimensions = () type = integer intent = in +[rrfs_smoke_band] + standard_name = rrtmg_band_number_that_smoke_and_dust_should_affect + long_name = rrtmg band number that smoke and dust should affect + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 20cbc054ac168d16b741520617836c0f888beb64 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 18:35:55 +0000 Subject: [PATCH 31/37] Switch arguments to implied shape --- smoke/rrfs_smoke_lsdep_wrapper.F90 | 8 +++---- smoke/rrfs_smoke_postpbl.F90 | 4 ++-- smoke/rrfs_smoke_wrapper.F90 | 36 +++++++++++++++--------------- 3 files changed, 24 insertions(+), 24 deletions(-) diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index d64866f41..aa0574fce 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -45,11 +45,11 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & integer, parameter :: ims=1,jms=1,jme=1, kms=1 integer, parameter :: its=1,jts=1,jte=1, kts=1 - real(kind_phys), dimension(im), intent(in) :: rain_cpl, rainc_cpl - real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + real(kind_phys), dimension(:), intent(in) :: rain_cpl, rainc_cpl + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & us3d, vs3d, spechum, w, dqdt - real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: gq0, qgrs + real(kind_phys), dimension(:,:,:), intent(inout) :: gq0, qgrs integer, intent(in) :: wetdep_ls_opt_in character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/smoke/rrfs_smoke_postpbl.F90 b/smoke/rrfs_smoke_postpbl.F90 index b9d61d42b..f83aaf795 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/smoke/rrfs_smoke_postpbl.F90 @@ -33,8 +33,8 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & integer, parameter :: its=1,kts=1 - real(kind_phys), dimension(ite,kte,ntrac), intent(inout) :: qgrs - real(kind_phys), dimension(ite,kte, 2), intent(inout) :: chem3d + real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index a179553b6..6d5bff569 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -59,27 +59,27 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, parameter :: ims=1,jms=1,jme=1, kms=1 integer, parameter :: its=1,jts=1,jte=1, kts=1 - integer, dimension(im), intent(in) :: land, vegtype, soiltyp - real(kind_phys), dimension(im,nsoil), intent(in) :: smc - real(kind_phys), dimension(im,12, 5), intent(in) :: dust12m_in - real(kind_phys), dimension(im,24, 3), intent(in) :: smoke_GBBEPx - real(kind_phys), dimension(im, 1), intent(in) :: emi_in - real(kind_phys), dimension(im), intent(in) :: u10m, v10m, ustar, dswsfc, & + integer, dimension(:), intent(in) :: land, vegtype, soiltyp + real(kind_phys), dimension(:,:), intent(in) :: smc + real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in + real(kind_phys), dimension(:,:,:), intent(in) :: smoke_GBBEPx + real(kind_phys), dimension(:,:), intent(in) :: emi_in + real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & rain_cpl, rainc_cpl, hf2d, t2m, dpt2m - real(kind_phys), dimension(im,kme), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(im,kte), intent(in) :: phl3d, prl3d, tk3d, & + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & us3d, vs3d, spechum, exch, w - real(kind_phys), dimension(im,kte,ntrac), intent(inout) :: qgrs, gq0 - real(kind_phys), dimension(im,kte, 2), intent(inout) :: chem3d - real(kind_phys), dimension(im), intent(inout) :: emdust, emseas, emanoc - real(kind_phys), dimension(im), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr - real(kind_phys), dimension(im ), intent(inout) :: coef_bb, fhist - real(kind_phys), dimension(im,kte), intent(inout) :: ebu_smoke - real(kind_phys), dimension(im), intent(inout) :: max_fplume, min_fplume - real(kind_phys), dimension(im), intent( out) :: hwp - real(kind_phys), dimension(im,kte), intent(out) :: smoke_ext, dust_ext - real(kind_phys), dimension(im,kte), intent(inout) :: nwfa, nifa + real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs, gq0 + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc + real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr + real(kind_phys), dimension(:), intent(inout) :: coef_bb, fhist + real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke + real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume + real(kind_phys), dimension(:), intent( out) :: hwp + real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext + real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa integer, intent(in ) :: imp_physics, imp_physics_thompson integer, intent(in) :: seas_opt_in, dust_opt_in, biomass_burn_opt_in, & drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in From f76236fb7d3dfd4716060f45ba49fe7750bebdab Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 6 May 2022 20:20:06 +0000 Subject: [PATCH 32/37] Remove some stops and gotos --- smoke/dep_wet_ls_mod.F90 | 19 +++----- smoke/module_plumerise1.F90 | 8 ++-- smoke/module_smoke_plumerise.F90 | 74 +++++++++++++++++++++----------- smoke/rrfs_smoke_data.F90 | 14 +++--- smoke/rrfs_smoke_wrapper.F90 | 3 +- 5 files changed, 73 insertions(+), 45 deletions(-) diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 index 23ceb803e..2790abc05 100755 --- a/smoke/dep_wet_ls_mod.F90 +++ b/smoke/dep_wet_ls_mod.F90 @@ -305,12 +305,12 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & do nv=1, num_chem ! Loop over spatial indices do j = j1, j2 - do i = i1, i2 + big_i_loop: do i = i1, i2 ! Check for total precipitation amount ! Assume no precip in column if precl+precc = 0 pac = precl(i,j) + precc(i,j) - if(pac .le. 0.) goto 100 + if(pac .le. 0.) cycle big_i_loop pls = precl(i,j) pcv = precc(i,j) @@ -327,12 +327,10 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & do k = k2, k1,-1 !lzhang if(dqcond(i,k,j) .lt. 0. .and. tmpu(i,k,j) .gt. 258.) then LH = k - goto 15 + exit endif end do - 15 continue - !if(LH .lt. 1) goto 100 - if(LH .gt. k2) goto 100 !lzhang + if(LH .gt. k2) cycle big_i_loop !lzhang ! convert dqcond from kg water/kg air/s to kg water/m3/s and reverse ! sign so that dqcond < 0. (positive precip) means qls and qcv > 0. @@ -392,11 +390,10 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & if (Qls(kk).gt.0.) then Qmx = max(Qmx,Qls(kk)) else - goto 333 + exit end if end do - 333 continue F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(Qmx*cdt/Td_ls)) if (F.lt.0.01) F = 0.01 !----------------------------------------------------------------------------- @@ -474,11 +471,10 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & if (Qcv(kk).gt.0.) then Qmx = max(Qmx,Qcv(kk)) else - goto 444 + exit end if end do - 444 continue F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qmx*cdt/Td_cv)) if (F.lt.0.01) F = 0.01 !----------------------------------------------------------------------------- @@ -554,8 +550,7 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k1,n)/cdt ! ug/m2/s end do - 100 continue - end do ! i + end do big_i_loop ! i end do ! j end do !nv for num_chem diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index f3c756b7e..6950fa0cb 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -41,7 +41,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, errmsg, errflg) use rrfs_smoke_config use physcons @@ -56,7 +56,8 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & real(kind=kind_phys), DIMENSION( ims:ime, jms:jme, 2 ), INTENT(IN ) :: plume_frp ! RAR: FRP etc. array ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg INTEGER, INTENT(IN ) :: ktau, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -187,8 +188,9 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & plume_frp(i,j,1), k_min(i,j), & - k_max(i,j), ktau, dbg_opt ) + k_max(i,j), ktau, dbg_opt, errmsg, errflg ) !k_max(i,j), ktau, config_flags%debug_chem ) + if(errflg/=0) return kp1= k_min(i,j) kp2= k_max(i,j) diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 index a9535f8b1..a3894ac5a 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/smoke/module_smoke_plumerise.F90 @@ -33,7 +33,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & - frp_inst,k1,k2, ktau, dbg_opt ) + frp_inst,k1,k2, ktau, dbg_opt, errmsg, errflg ) implicit none type(smoke_data), intent(inout) :: data @@ -49,6 +49,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & INTEGER, INTENT (IN) :: ktau INTEGER, INTENT (OUT) :: k1,k2 + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg ! integer :: ncall = 0 integer :: kmt @@ -144,7 +146,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! enddo !- get envinronmental state (temp, water vapor mix ratio, ...) - call get_env_condition(coms,1,m1,kmt,wind_eff,ktau) + call get_env_condition(coms,1,m1,kmt,wind_eff,ktau,errmsg,errflg) + if(errflg/=0) return !- loop over the four types of aggregate biomes with fires for plumerise version 1 !- for plumerise version 2, there is exist only one loop @@ -177,7 +180,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & END IF !- get fire properties (burned area, plume radius, heating rates ...) - call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) + call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) + if(errflg/=0) return !------ generates the plume rise ------ call makeplume (coms,kmt,ztopmax(imm),ixx,imm) @@ -217,7 +221,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & end subroutine plumerise !------------------------------------------------------------------------- -subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,errmsg,errflg) !se module_zero_plumegen_coms !use rconstants @@ -227,6 +231,8 @@ subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy !integer :: n_setgrid = 0 integer :: wind_eff,ktau +character(*), intent(inout) :: errmsg +integer, intent(inout) :: errflg if(ktau==2) then ! n_setgrid = 1 @@ -236,20 +242,31 @@ subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau) endif znz=coms%zcon(k2) +errflg=1 do k=nkp,1,-1 - if(coms%zt(k).lt.znz)go to 13 + if(coms%zt(k).lt.znz) then + errflg=0 + exit + endif enddo -stop ' envir stop 12' -13 continue +if(errflg/=0) then + errmsg=' envir stop 12' + return +endif !-srf-mb kmt=min(k,nkp-1) nk=k2-k1+1 -!call htint(nk, coms%wcon,coms%zzcon,kmt,wpe,coms%zt) - call htint(nk, coms%ucon,coms%zcon,kmt,coms%upe,coms%zt) - call htint(nk, coms%vcon,coms%zcon,kmt,coms%vpe,coms%zt) - call htint(nk,coms%thtcon,coms%zcon,kmt,coms%the ,coms%zt) - call htint(nk, coms%rvcon,coms%zcon,kmt,coms%qvenv,coms%zt) +!call htint(nk, coms%wcon,coms%zzcon,kmt,wpe,coms%zt,errmsg,errflg) +!if(errflg/=0) return + call htint(nk, coms%ucon,coms%zcon,kmt,coms%upe,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk, coms%vcon,coms%zcon,kmt,coms%vpe,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk,coms%thtcon,coms%zcon,kmt,coms%the ,coms%zt,errmsg,errflg) + if(errflg/=0) return + call htint(nk, coms%rvcon,coms%zcon,kmt,coms%qvenv,coms%zt,errmsg,errflg) + if(errflg/=0) return do k=1,kmt coms%qvenv(k)=max(coms%qvenv(k),1e-8) enddo @@ -422,13 +439,15 @@ SUBROUTINE set_flam_vert(ztopmax,k1,k2,nkp,zzcon) !,W_VMD,VMD) END SUBROUTINE set_flam_vert !------------------------------------------------------------------------- -subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) +subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) !use module_zero_plumegen_coms implicit none type(plumegen_coms), pointer :: coms integer :: moist, i, icount,imm,iveg_ag !,plumerise_flag real(kind=kind_phys):: bfract, effload, heat, hinc ,burnt_area,heat_fluxW,FRP real(kind=kind_phys), dimension(2,4) :: heat_flux +integer, intent(inout) :: errflg +character(*), intent(inout) :: errmsg INTEGER, parameter :: use_last = 0 !real(kind=kind_phys), parameter :: beta = 5.0 !ref.: Wooster et al., 2005 REAL(kind=kind_phys), parameter :: beta = 0.88 !ref.: Paugam et al., 2015 @@ -522,7 +541,11 @@ subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP) ! except for the first few minutes for stability ICOUNT = 1 ! - if(COMS%MDUR > NTIME) STOP 'Increase time duration (ntime) in min - see file "module_zero_plumegen_coms.F90"' + if(COMS%MDUR > NTIME) then + errmsg = 'Increase time duration (ntime) in min - see file "module_zero_plumegen_coms.F90"' + errflg = 1 + return + endif DO WHILE (ICOUNT.LE.COMS%MDUR) ! COMS%HEATING (ICOUNT) = HEAT * EFFLOAD / COMS%TDUR ! W/m**2 @@ -1933,7 +1956,7 @@ SUBROUTINE EVAPORATE(coms) ! sd is still positive or we wouldn't be here. - IF (COMS%QH (COMS%L) .LE.1.E-10) GOTO 33 + IF (COMS%QH (COMS%L) > 1.E-10) THEN !srf-25082005 ! QUANT = ( COMS%QC (COMS%L) + COMS%QV (COMS%L) - COMS%QSAT (COMS%L) ) * COMS%RHO (COMS%L) !g/m**3 @@ -1982,7 +2005,7 @@ SUBROUTINE EVAPORATE(coms) ! now for ice ! equation from (OT); correction factors for units applied ! - 33 continue + ENDIF IF (COMS%QI (COMS%L) .LE.1.E-10) RETURN !no ice there ! DIVIDEND = ( (1.E6 / COMS%RHO (COMS%L) ) **0.475) * (SD / COMS%QSAT (COMS%L) & @@ -2273,7 +2296,7 @@ SUBROUTINE MELT(coms) ! END SUBROUTINE MELT -SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) +SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb, errmsg, errflg) IMPLICIT NONE INTEGER, INTENT(IN ) :: nzz1 INTEGER, INTENT(IN ) :: nzz2 @@ -2281,7 +2304,8 @@ SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) REAL(kind=kind_phys), INTENT(OUT) :: vctrb(nzz2) REAL(kind=kind_phys), INTENT(IN ) :: eleva(nzz1) REAL(kind=kind_phys), INTENT(IN ) :: elevb(nzz2) - + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg INTEGER :: l INTEGER :: k INTEGER :: kk @@ -2308,7 +2332,8 @@ SUBROUTINE htint (nzz1, vctra, eleva, nzz2, vctrb, elevb) DO kk=1,l PRINT*,'kk,eleva(kk),elevb(kk)',kk,eleva(kk),elevb(kk) END DO - STOP 'htint' + errmsg='htint assertion failure (see print for details)' + errflg=1 END IF END DO END DO @@ -2331,13 +2356,14 @@ FUNCTION ESAT_PR (TEM) ! ! TEMC = TEM - TMELT -IF (TEMC.GT. - 40.0) GOTO 230 -ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars -ESAT_PR = ESATM / 10. !kPa +IF (TEMC<= - 40.0) then + ESATM = CI1 * EXP (CI2 * TEMC / (TEMC + CI3) ) !ice, millibars + ESAT_PR = ESATM / 10. !kPa -RETURN + RETURN +ENDIF ! -230 ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) +ESATM = CW1 * EXP ( ( (CW2 - (TEMC / CW4) ) * TEMC) / (TEMC + CW3)) ESAT_PR = ESATM / 10. !kPa RETURN diff --git a/smoke/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 index f1d11960a..cb9cc25e6 100755 --- a/smoke/rrfs_smoke_data.F90 +++ b/smoke/rrfs_smoke_data.F90 @@ -147,13 +147,15 @@ end subroutine smoke_data_destructor ! SUBROUTINE dep_init( id, numgas, mminlu_loc, & ! ips, ipe, jps, jpe, ide, jde ) - SUBROUTINE dep_init(this) + SUBROUTINE dep_init(this,errmsg,errflg) ! Lifted out of dep_simple_mod, this initializes ! member variables that were module variables in ! that module. !-- implicit none class(smoke_data) :: this + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg !-------------------------------------------------- ! .. Scalar Arguments .. @@ -220,12 +222,14 @@ SUBROUTINE dep_init(this) 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ ! .. IF (nlu/=25) THEN - write(0,*) 'number of land use classifications not correct ' - stop + errmsg='number of land use classifications not correct ' + errflg=1 + return END IF IF (dep_seasons/=5) THEN - write(0,*) 'number of dep_seasons not correct ' - stop + errmsg='number of dep_seasons not correct ' + errflg=1 + return END IF ! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index 6d5bff569..ae7deccbc 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -341,7 +341,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, plume_frp, min_fplume2, max_fplume2, & ! new approach ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, errmsg, errflg ) + if(errflg/=0) return end if ! -- add biomass burning emissions at every timestep From aaca3b0f8bf777aaa10eec8f60b2d43a2ce7d7cb Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 9 May 2022 20:00:23 +0000 Subject: [PATCH 33/37] Remove some hard-coded constants and rename some meta entries --- physics/GFS_rrtmg_pre.meta | 6 +-- physics/mp_thompson.meta | 4 +- physics/mynnedmf_wrapper.meta | 8 +-- smoke/dep_wet_ls_mod.F90 | 5 +- smoke/module_plumerise1.F90 | 11 ++-- smoke/module_smoke_plumerise.F90 | 18 ++++--- smoke/rrfs_smoke_lsdep_wrapper.F90 | 13 +++-- smoke/rrfs_smoke_lsdep_wrapper.meta | 14 +++-- smoke/rrfs_smoke_postpbl.meta | 4 +- smoke/rrfs_smoke_wrapper.F90 | 21 ++++---- smoke/rrfs_smoke_wrapper.meta | 84 ++++++++++++++++++++--------- smoke/seas_mod.F90 | 15 +++--- smoke/seas_ngac_mod.F90 | 4 +- 13 files changed, 126 insertions(+), 81 deletions(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 695ae65ef..2543cf58e 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1195,8 +1195,8 @@ kind = kind_phys intent = out [aero_dir_fdb] - standard_name = rrfs_smoke_dust_rad_fdb_opt - long_name = flag for rrfs smoke dust rad feedback + standard_name = do_smoke_aerosol_direct_feedback + long_name = flag for smoke and dust radiation feedback units = flag dimensions = () type = logical @@ -1233,7 +1233,7 @@ type = integer intent = in [rrfs_smoke_band] - standard_name = rrtmg_band_number_that_smoke_and_dust_should_affect + standard_name = index_of_shortwave_band_affected_by_smoke long_name = rrtmg band number that smoke and dust should affect units = count dimensions = () diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 4e82bd982..9981b119d 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -436,8 +436,8 @@ kind = kind_phys intent = in [aero_ind_fdb] - standard_name = rrfs_smoke_aero_ind_fdb_opt - long_name = flag for rrfs wfa ifa emission + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for wfa ifa emission indirect feedback units = flag dimensions = () type = logical diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index 7fbb85311..e2a543734 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1353,21 +1353,21 @@ intent = inout [frp] standard_name = frp_hourly - long_name = hourly frp - units = mw + long_name = hourly fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [mix_chem] - standard_name = rrfs_smoke_mynn_tracer_mixing + standard_name = do_planetary_boundary_layer_smoke_mixing long_name = flag for rrfs smoke mynn tracer mixing units = flag dimensions = () type = logical intent = in [fire_turb] - standard_name = rrfs_smoke_mynn_enh_vermix + standard_name = do_planetary_boundary_layer_fire_enhancement long_name = flag for rrfs smoke mynn enh vermix units = flag dimensions = () diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 index 2790abc05..3a7a186ea 100755 --- a/smoke/dep_wet_ls_mod.F90 +++ b/smoke/dep_wet_ls_mod.F90 @@ -5,7 +5,6 @@ module dep_wet_ls_mod use rrfs_smoke_data use machine , only : kind_phys use rrfs_smoke_config - use physcons, only : grav => con_g ! use chem_tracers_mod ! use chem_rc_mod ! use chem_tracers_mod @@ -206,7 +205,7 @@ end subroutine wetdep_ls subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & num_chem, var_rmv, chem, ple, tmpu, & - rhoa, dqcond, precc, precl, & + rhoa, dqcond, precc, precl, grav, & ims, ime, jms, jme, kms, kme) ! ims, ime, jms, jme, kms, kme, rc ) @@ -217,7 +216,7 @@ subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & ! !INPUT PARAMETERS: integer, intent(in) :: i1, i2, j1, j2, k1, k2, n1, n2, num_chem, & ims, ime, jms, jme, kms, kme - real(kind_phys), intent(in) :: cdt + real(kind_phys), intent(in) :: cdt, grav REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem),& INTENT(INOUT) :: chem REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index 6950fa0cb..ee4854308 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -5,6 +5,7 @@ module module_plumerise1 use rrfs_smoke_data use machine , only : kind_phys + real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) !- Implementing the fire radiative power (FRP) methodology for biomass burning !- emissions and convective energy estimation. !- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) @@ -37,7 +38,7 @@ module module_plumerise1 subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & t_phy,q_vap, & ! RAR: moist is replaced with q_vap rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,z,ktau, & ! scale_fire_emiss is part of config_flags + z_at_w,z,ktau,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -66,6 +67,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! INTENT(IN ) :: moist real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu + real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac @@ -87,7 +89,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & !real(kind_phys), dimension (num_ebu) :: eburn_in !real(kind_phys), dimension (kte,num_ebu) :: eburn_out real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev - real(kind=kind_phys) :: dz_plume + real(kind=kind_phys) :: dz_plume, cpor, con_rocp !INTEGER, PARAMETER :: kfire_max=30 ! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct @@ -111,6 +113,8 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10) ! enddo ! enddo + cpor =con_cp/con_rd + con_rocp=con_rd/con_cp IF ( dbg_opt .and. ktau<2000) then WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte @@ -188,7 +192,8 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & plume_frp(i,j,1), k_min(i,j), & - k_max(i,j), ktau, dbg_opt, errmsg, errflg ) + k_max(i,j), ktau, dbg_opt, g, con_cp, & + con_rd, cpor, errmsg, errflg ) !k_max(i,j), ktau, config_flags%debug_chem ) if(errflg/=0) return diff --git a/smoke/module_smoke_plumerise.F90 b/smoke/module_smoke_plumerise.F90 index a3894ac5a..247b09f92 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/smoke/module_smoke_plumerise.F90 @@ -16,16 +16,13 @@ module module_smoke_plumerise use machine , only : kind_phys use rrfs_smoke_data use rrfs_smoke_config, only : FIRE_OPT_GBBEPx, FIRE_OPT_MODIS - use physcons, only : g => con_g, cp => con_cp, r_d => con_rd, r_v =>con_rv use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & !tropical_forest, boreal_forest, savannah, grassland, & wind_eff USE module_zero_plumegen_coms - real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) - real(kind=kind_phys),parameter :: rgas=r_d - real(kind=kind_phys),parameter :: cpor=cp/r_d - real(kind=kind_phys),parameter :: p00=p1000mb + !real(kind=kind_phys),parameter :: rgas=r_d + !real(kind=kind_phys),parameter :: cpor=cp/r_d CONTAINS ! RAR: @@ -33,7 +30,8 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & - frp_inst,k1,k2, ktau, dbg_opt, errmsg, errflg ) + frp_inst,k1,k2, ktau, dbg_opt, g, cp, rgas, & + cpor, errmsg, errflg ) implicit none type(smoke_data), intent(inout) :: data @@ -44,6 +42,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! integer, intent(in) :: PLUMERISE_flag real(kind=kind_phys) :: frp_inst ! This is the instantenous FRP, at a given time step + real(kind=kind_phys) :: g, cp, rgas, cpor integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies @@ -146,7 +145,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! enddo !- get envinronmental state (temp, water vapor mix ratio, ...) - call get_env_condition(coms,1,m1,kmt,wind_eff,ktau,errmsg,errflg) + call get_env_condition(coms,1,m1,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) if(errflg/=0) return !- loop over the four types of aggregate biomes with fires for plumerise version 1 @@ -221,13 +220,16 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & end subroutine plumerise !------------------------------------------------------------------------- -subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,errmsg,errflg) +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) !se module_zero_plumegen_coms !use rconstants implicit none type(plumegen_coms), pointer :: coms +real(kind=kind_phys) :: g,cp,rgas,cpor integer :: k1,k2,k,kcon,klcl,kmt,nk,nkmid,i +real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) +real(kind=kind_phys),parameter :: p00=p1000mb real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy !integer :: n_setgrid = 0 integer :: wind_eff,ktau diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 index aa0574fce..1fd7a2d3f 100644 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ b/smoke/rrfs_smoke_lsdep_wrapper.F90 @@ -4,7 +4,6 @@ module rrfs_smoke_lsdep_wrapper - use physcons, only : g => con_g, pi => con_pi use machine , only : kind_phys use rrfs_smoke_config use dep_wet_ls_mod @@ -28,7 +27,7 @@ module rrfs_smoke_lsdep_wrapper !>\section rrfs_smoke_lsdep_wrapper GSD Chemistry Scheme General Algorithm !> @{ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & - rain_cpl, rainc_cpl, & + rain_cpl, rainc_cpl, g, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & w, dqdt, ntrac,ntsmoke,ntdust, & gq0,qgrs,wetdep_ls_opt_in, & @@ -39,7 +38,7 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & integer, intent(in) :: im,kte,kme,ktau integer, intent(in) :: ntrac,ntsmoke,ntdust - real(kind_phys),intent(in) :: dt + real(kind_phys),intent(in) :: dt,g integer, parameter :: ids=1,jds=1,jde=1, kds=1 integer, parameter :: ims=1,jms=1,jme=1, kms=1 @@ -119,7 +118,7 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & call rrfs_smoke_prep_lsdep(data,ktau,dtstep, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel, & + t8w,dqdti,z_at_w,vvel,g, & ntsmoke,ntdust, & ntrac,gq0,num_chem, num_moist, & ppm2ugkg,moist,chem, & @@ -138,7 +137,7 @@ subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & case (WDLS_OPT_NGAC) call WetRemovalGOCART(data,its,ite, jts,jte, kts,kte, 1,1, dt, & num_chem,var_rmv,chem,p_phy,t_phy, & - rho_phy,dqdti,rcav,rnav, & + rho_phy,dqdti,rcav,rnav, g, & ims,ime, jms,jme, kms,kme) !if (chem_rc_check(localrc, msg="Failure in NGAC wet removal scheme", & ! file=__FILE__, line=__LINE__, rc=rc)) return @@ -170,7 +169,7 @@ end subroutine rrfs_smoke_lsdep_wrapper_run subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel, & + t8w,dqdti,z_at_w,vvel,g, & ntsmoke,ntdust, & ntrac,gq0,num_chem, num_moist, & ppm2ugkg,moist,chem, & @@ -182,7 +181,7 @@ subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & !Chem input configuration integer, intent(in) :: ktau - real(kind=kind_phys), intent(in) :: dtstep + real(kind=kind_phys), intent(in) :: dtstep,g !FV3 input variables integer, intent(in) :: ntrac,ntsmoke,ntdust diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/smoke/rrfs_smoke_lsdep_wrapper.meta index 8a9ff5462..23c71fce8 100755 --- a/smoke/rrfs_smoke_lsdep_wrapper.meta +++ b/smoke/rrfs_smoke_lsdep_wrapper.meta @@ -59,6 +59,14 @@ type = real kind = kind_phys intent = in +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in [pr3d] standard_name = air_pressure_at_interface long_name = air pressure at model layer interfaces @@ -147,14 +155,14 @@ type = integer intent = in [ntsmoke] - standard_name = index_for_smoke + standard_name = index_for_smoke_in_tracer_concentration_array long_name = tracer index for smoke units = index dimensions = () type = integer intent = in [ntdust] - standard_name = index_for_dust + standard_name = index_for_dust_in_tracer_concentration_array long_name = tracer index for dust units = index dimensions = () @@ -177,7 +185,7 @@ kind = kind_phys intent = inout [wetdep_ls_opt_in] - standard_name = rrfs_smoke_wetdep_ls_opt + standard_name = control_for_smoke_wet_deposition long_name = rrfs smoke large scale wet deposition option units = index dimensions = () diff --git a/smoke/rrfs_smoke_postpbl.meta b/smoke/rrfs_smoke_postpbl.meta index 45ca60cb4..99aae69f2 100755 --- a/smoke/rrfs_smoke_postpbl.meta +++ b/smoke/rrfs_smoke_postpbl.meta @@ -22,14 +22,14 @@ type = integer intent = in [ntsmoke] - standard_name = index_for_smoke + standard_name = index_for_smoke_in_tracer_concentration_array long_name = tracer index for smoke units = index dimensions = () type = integer intent = in [ntdust] - standard_name = index_for_dust + standard_name = index_for_dust_in_tracer_concentration_array long_name = tracer index for dust units = index dimensions = () diff --git a/smoke/rrfs_smoke_wrapper.F90 b/smoke/rrfs_smoke_wrapper.F90 index ae7deccbc..ac32e1ad4 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/smoke/rrfs_smoke_wrapper.F90 @@ -4,7 +4,6 @@ module rrfs_smoke_wrapper - use physcons, only : g => con_g, pi => con_pi use machine , only : kind_phys use rrfs_smoke_config use dust_data_mod @@ -36,8 +35,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & - julian, idat, rain_cpl, rainc_cpl, exch, hf2d, & - dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & + julian, idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, & + dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & ntsmoke, ntdust, imp_physics, imp_physics_thompson, & nwfa, nifa, emanoc, & emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & @@ -52,7 +51,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) integer, intent(in) :: ntrac, ntsmoke, ntdust - real(kind_phys),intent(in) :: dt, julian + real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in integer, parameter :: ids=1,jds=1,jde=1, kds=1 @@ -138,8 +137,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), parameter :: mean_diameter2= 1.E-6, sigma2=1.8 real(kind_phys), parameter :: kappa_oc = 0.2 real(kind_phys), parameter :: kappa_dust = 0.04 - real(kind_phys), parameter :: fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 - real(kind_phys), parameter :: fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 + real(kind_phys) :: fact_wfa, fact_ifa !> -- aerosol density (kg/m3) real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 @@ -243,7 +241,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & snow,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, & + hf2d, pb2d, g, pi, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & @@ -305,7 +303,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, if (seas_opt >= SEAS_OPT_DEFAULT) then call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & - xland,xlat,xlong,dxy,g,emis_seas, & + xland,xlat,xlong,dxy,g,emis_seas,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -337,7 +335,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, data,flam_frac,ebu_in,ebu, & t_phy,moist(:,:,:,p_qv), & rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,zmid,ktau, & + z_at_w,zmid,ktau,g,con_cp,con_rd, & plume_frp, min_fplume2, max_fplume2, & ! new approach ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -432,6 +430,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau !-- to provide real aerosol emission for Thompson MP if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then + fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 + fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 do i = its, ite do k = kts, kte @@ -463,7 +463,7 @@ subroutine rrfs_smoke_prep( & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & snow_cpl,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, & + hf2d, pb2d, g, pi, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & @@ -488,6 +488,7 @@ subroutine rrfs_smoke_prep( & integer, intent(in) :: nsoil integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp integer, intent(in) :: ntrac + real(kind=kind_phys), intent(in) :: g, pi real(kind=kind_phys), dimension(ims:ime), intent(in) :: & u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & zorl, snow_cpl, pb2d, hf2d diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index 709ea00d1..e09b74ac1 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -317,6 +317,38 @@ type = real kind = kind_phys intent = in +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[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 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [dust12m_in] standard_name = fengsha_dust12m_input long_name = fengsha dust input @@ -380,14 +412,14 @@ type = integer intent = in [ntsmoke] - standard_name = index_for_smoke + standard_name = index_for_smoke_in_tracer_concentration_array long_name = tracer index for smoke units = index dimensions = () type = integer intent = in [ntdust] - standard_name = index_for_dust + standard_name = index_for_dust_in_tracer_concentration_array long_name = tracer index for dust units = index dimensions = () @@ -448,7 +480,7 @@ kind = kind_phys intent = inout [ebb_smoke_hr] - standard_name = surfce_emission_of_smoke + standard_name = surface_smoke_emission long_name = emission of surface smoke units = ug m-2 s-1 dimensions = (horizontal_loop_extent) @@ -457,23 +489,23 @@ intent = inout [frp_hr] standard_name = frp_hourly - long_name = hourly frp - units = mw + long_name = hourly fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [frp_std_hr] standard_name = frp_std_hourly - long_name = hourly std frp - units = mw + long_name = hourly stdandard deviation of fire radiative power + units = MW dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [coef_bb] standard_name = coef_bb_dc - long_name = coef bb dc from plumerise + long_name = coef to estimate the fire emission units = none dimensions = (horizontal_loop_extent) type = real @@ -481,38 +513,38 @@ intent = inout [ebu_smoke] standard_name = ebu_smoke - long_name = smoke buffer of ebu + long_name = buffer of vertical fire emission units = various dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout [fhist] - standard_name = fhist - long_name = fire hist + standard_name = fire_hist + long_name = coefficient to scale the fire activity depending on the fire duration units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [min_fplume] - standard_name = min_fplume - long_name = miminum plume height + standard_name = minimum_fire_plume_sigma_pressure_level + long_name = minimum model level of fire plumerise units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [max_fplume] - standard_name = max_fplume - long_name = maximum plume height + standard_name = maximum_fire_plume_sigma_pressure_level + long_name = maximum model level of fire plumerise units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [hwp] - standard_name = rrfs_hwp + standard_name = hourly_wildfire_potential long_name = rrfs hourly fire weather potential units = none dimensions = (horizontal_loop_extent) @@ -536,44 +568,44 @@ kind = kind_phys intent = out [seas_opt_in] - standard_name = rrfs_smoke_sea_salt_opt + standard_name = control_for_smoke_sea_salt long_name = rrfs smoke sea salt emission option units = index dimensions = () type = integer intent = in [dust_opt_in] - standard_name = rrfs_smoke_dust_opt + standard_name = control_for_smoke_dust long_name = rrfs smoke dust chem option units = index dimensions = () type = integer intent = in [biomass_burn_opt_in] - standard_name = rrfs_smoke_biomass_burn_opt + standard_name = control_for_smoke_biomass_burn long_name = rrfs smoke biomass burning option units = index dimensions = () type = integer intent = in [drydep_opt_in] - standard_name = rrfs_smoke_drydep_opt + standard_name = control_for_smoke_dry_deposition long_name = rrfs smoke dry deposition option units = index dimensions = () type = integer intent = in [do_plumerise_in] - standard_name = rrfs_smoke_plumerise_flag + standard_name = do_smoke_plumerise long_name = rrfs smoke plumerise option units = index dimensions = () type = logical intent = in [plumerisefire_frq_in] - standard_name = rrfs_smoke_plumerisefire_frq + standard_name = smoke_plumerise_frequency long_name = rrfs smoke add smoke option - units = index + units = min dimensions = () type = integer intent = in @@ -585,21 +617,21 @@ type = integer intent = in [smoke_forecast_in] - standard_name = rrfs_smoke_smoke_forecast_opt + standard_name = do_smoke_forecast long_name = flag for rrfs smoke forecast units = flag dimensions = () type = logical intent = in [aero_ind_fdb_in] - standard_name = rrfs_smoke_aero_ind_fdb_opt + standard_name = do_smoke_aerosol_indirect_feedback long_name = flag for rrfs wfa ifa emission units = flag dimensions = () type = logical intent = in [dbg_opt_in] - standard_name = rrfs_smoke_plumerise_debug + standard_name = do_smoke_debug long_name = flag for rrfs smoke plumerise debug units = flag dimensions = () diff --git a/smoke/seas_mod.F90 b/smoke/seas_mod.F90 index 78bcef5be..85c861156 100755 --- a/smoke/seas_mod.F90 +++ b/smoke/seas_mod.F90 @@ -4,7 +4,6 @@ module seas_mod use machine , only : kind_phys - use physcons, only : pi=>con_pi ! use chem_rc_mod, only : chem_rc_test ! use chem_tracers_mod, only : p_seas_1, p_seas_2, p_seas_3, p_seas_4, p_seas_5, & ! p_eseas1, p_eseas2, p_eseas3, p_eseas4, p_eseas5, & @@ -31,7 +30,7 @@ module seas_mod subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & v_phy,chem,rho_phy,dz8w,u10,v10,ustar,p8w,tsk, & - xland,xlat,xlong,area,g,emis_seas, & + xland,xlat,xlong,area,g,emis_seas,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -65,7 +64,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & dz8w,p8w, & u_phy,v_phy,rho_phy - REAL(kind=kind_phys), INTENT(IN ) :: dt,g + REAL(kind=kind_phys), INTENT(IN ) :: dt,g,pi ! integer, parameter :: p_seas_1=15 integer, parameter :: p_seas_2=16 @@ -141,7 +140,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & airmas1(1,1,1) = airmas(1,1) tc1(1,1,1,:) = tc bems1(1,1,:) = bems - call source_ss( imx, jmx, lmx, number_ss_bins, dt, tc1,ilwi, dxy, w10m, airmas1, bems1,ipr) + call source_ss( imx, jmx, lmx, number_ss_bins, dt, tc1, pi, ilwi, dxy, w10m, airmas1, bems1,ipr) tc = tc1(1,1,1,:) chem(i,kts,j,p_seas_1)=(tc(1)+.75*tc(2))*converi chem(i,kts,j,p_seas_2)=(tc(3)+.25*tc(2))*converi @@ -179,7 +178,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & airmas1(1,1,1) = airmas(1,1) tc1(1,1,1,:) = tc bems1(1,1,:) = bems - call source_ss( imx,jmx,lmx,number_ss_bins, dt, tc1, ilwi, dxy, w10m, airmas1, bems1,ipr) + call source_ss( imx,jmx,lmx,number_ss_bins, dt, tc1, pi, ilwi, dxy, w10m, airmas1, bems1,ipr) tc = tc1(1,1,1,:) bems = bems1(1,1,:) @@ -232,7 +231,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & memissions = 0. nemissions = 0. call SeasaltEmission( ra(n), rb(n), emission_scheme, & - ws10m, ustar(i,j), memissions, nemissions, rc ) + ws10m, ustar(i,j), pi, memissions, nemissions, rc ) ! if (chem_rc_test((rc /= 0), msg="Error in NGAC sea salt scheme", & ! file=__FILE__, line=__LINE__)) return @@ -267,7 +266,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & end subroutine gocart_seasalt_driver - SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, & + SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, pi, & ilwi, dxy, w10m, airmas, & bems,ipr) @@ -308,7 +307,7 @@ SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, & INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,ipr INTEGER, INTENT(IN) :: ilwi(imx,jmx) - REAL(kind=kind_phys), INTENT(IN) :: dxy(jmx), w10m(imx,jmx) + REAL(kind=kind_phys), INTENT(IN) :: dxy(jmx), w10m(imx,jmx), pi REAL(kind=kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) REAL(kind=kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) REAL(kind=kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) diff --git a/smoke/seas_ngac_mod.F90 b/smoke/seas_ngac_mod.F90 index 411635db2..2158d808c 100755 --- a/smoke/seas_ngac_mod.F90 +++ b/smoke/seas_ngac_mod.F90 @@ -18,7 +18,6 @@ module seas_ngac_mod ! use chem_comm_mod, only : chem_comm_isroot use machine , only : kind_phys - use physcons, only : pi=>con_pi implicit none @@ -58,7 +57,7 @@ module seas_ngac_mod ! ! !INTERFACE: ! - subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, & + subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, pi, & memissions, nemissions, rc ) ! !DESCRIPTION: Calculates the seasalt mass emission flux every timestep. @@ -79,6 +78,7 @@ subroutine SeasaltEmission ( rLow, rUp, method, w10m, ustar, & real(kind=kind_phys), intent(in) :: rLow, rUp ! Dry particle bin edge radii [um] real(kind=kind_phys), intent(in) :: w10m ! 10-m wind speed [m s-1] real(kind=kind_phys), intent(in) :: ustar ! friction velocity [m s-1] + real(kind=kind_phys), intent(in) :: pi ! ratio of a circle's circumference to its diameter integer, intent(in) :: method ! Algorithm to use ! !OUTPUT PARAMETERS: From 552d948c6f824386623b59c0c569994e43c98700 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 9 May 2022 21:16:42 +0000 Subject: [PATCH 34/37] Rename some standard_names, change a unit, and remove a "use physcons" --- physics/mynnedmf_wrapper.meta | 2 +- physics/mynnsfc_wrapper.meta | 12 ++++++------ smoke/module_plumerise1.F90 | 1 - smoke/rrfs_smoke_wrapper.meta | 2 +- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index e2a543734..01e8e1d9e 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1283,7 +1283,7 @@ [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 + units = 1 dimensions = () type = real intent = in diff --git a/physics/mynnsfc_wrapper.meta b/physics/mynnsfc_wrapper.meta index 5d30d71f3..d89cc5d35 100644 --- a/physics/mynnsfc_wrapper.meta +++ b/physics/mynnsfc_wrapper.meta @@ -158,28 +158,28 @@ type = integer intent = in [isftcflx] - standard_name = flag_for_thermal_roughness_lengths_over_water_in_mynnsfclay + standard_name = control_for_thermal_roughness_lengths_over_water long_name = flag for thermal roughness lengths over water in mynnsfclay - units = flag + units = 1 dimensions = () type = integer intent = in [iz0tlnd] - standard_name = flag_for_thermal_roughness_lengths_over_land_in_mynnsfclay + standard_name = control_for_thermal_roughness_lengths_over_land long_name = flag for thermal roughness lengths over land in mynnsfclay - units = flag + units = 1 dimensions = () type = integer intent = in [sfclay_compute_flux] - standard_name = flag_for_computing_surface_scalar_fluxes_in_mynnsfclay + standard_name = do_compute_surface_scalar_fluxes long_name = flag for computing surface scalar fluxes in mynnsfclay units = flag dimensions = () type = logical intent = in [sfclay_compute_diag] - standard_name = flag_for_computing_surface_diagnostics_in_mynnsfclay + standard_name = do_compute_surface_diagnostics long_name = flag for computing surface diagnostics in mynnsfclay units = flag dimensions = () diff --git a/smoke/module_plumerise1.F90 b/smoke/module_plumerise1.F90 index ee4854308..47bb4e74a 100755 --- a/smoke/module_plumerise1.F90 +++ b/smoke/module_plumerise1.F90 @@ -45,7 +45,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & its,ite, jts,jte, kts,kte, errmsg, errflg) use rrfs_smoke_config - use physcons use plume_data_mod USE module_zero_plumegen_coms USE module_smoke_plumerise diff --git a/smoke/rrfs_smoke_wrapper.meta b/smoke/rrfs_smoke_wrapper.meta index e09b74ac1..ef46b04ea 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/smoke/rrfs_smoke_wrapper.meta @@ -610,7 +610,7 @@ type = integer intent = in [addsmoke_flag_in] - standard_name = rrfs_smoke_addsmoke_flag + standard_name = control_for_smoke_biomass_burning_emissions long_name = rrfs smoke add smoke option units = index dimensions = () From 49c70967f78e3a5d5293bab43c81acc6076cd060 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 10 May 2022 13:49:55 -0400 Subject: [PATCH 35/37] make sure that tsfc_wat is calculated when wet = T --- physics/scm_sfc_flux_spec.F90 | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index fc4aaf5d1..bb2c47f48 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -153,14 +153,11 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, frland(i) = 1.0_kind_phys cice(i) = 0.0_kind_phys icy(i) = .false. - tsfcl(i) = T_surf(i) !GJF else frland(i) = 0.0_kind_phys if (oceanfrac(i) > 0.0_kind_phys) then if (cice(i) >= min_seaice) then icy(i) = .true. - tisfc(i) = T_surf(i) !GJF - tisfc(i) = max(timin, min(tisfc(i), tgice)) ! This cplice namelist option was added to deal with the ! situation of the FV3ATM-HYCOM coupling without an active sea ! ice (e.g., CICE6) component. By default, the cplice is true @@ -186,8 +183,6 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, else if (cice(i) >= min_lakeice) then icy(i) = .true. - tisfc(i) = T_surf(i) !GJF - tisfc(i) = max(timin, min(tisfc(i), tgice)) islmsk(i) = 2 else cice(i) = 0.0_kind_phys @@ -198,13 +193,23 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, if (cice(i) < 1.0_kind_phys) then wet(i) = .true. ! some open lake endif - if (wet(i)) then ! Water - tsfc_wat(i) = T_surf(i) - endif endif endif if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo + + do i = 1, im + if (wet(i)) then + tsfc_wat(i) = T_surf(i) + end if + if (dry(i)) then + tsfcl(i) = T_surf(i) + end if + if (icy(i)) then + tisfc(i) = T_surf(i) + tisfc(i) = max(timin, min(tisfc(i), tgice)) + end if + end do ! to prepare to separate lake from ocean under water category do i = 1, im From eb1ba70428315983b4e4b8a66da200a0c635bc75 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 16 May 2022 17:45:16 +0000 Subject: [PATCH 36/37] Pass some chemistry varibles to mynn_bl_driver correctly --- physics/module_bl_mynn.F90 | 14 +++++++------- physics/mynnedmf_wrapper.F90 | 5 +++-- physics/mynnedmf_wrapper.meta | 7 +++++++ 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 409fb3740..50685b403 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -397,7 +397,7 @@ SUBROUTINE mynn_bl_driver( & &nchem,kdvel,ndvel, & !Smoke/Chem variables &chem3d, vdep, & &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,fire_turb, & ! end smoke/chem variables + &mix_chem,fire_turb,rrfs_smoke, & ! end smoke/chem variables &Tsq,Qsq,Cov, & &RUBLTEN,RVBLTEN,RTHBLTEN, & @@ -457,7 +457,7 @@ SUBROUTINE mynn_bl_driver( & LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA - LOGICAL, INTENT(IN) :: mix_chem,fire_turb + LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & @@ -537,9 +537,9 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel ! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d ! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d - REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep - REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO + REAL, DIMENSION(:, :, :), INTENT(INOUT) :: chem3d + REAL, DIMENSION(:, :), INTENT(IN) :: vdep + REAL, DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local REAL, DIMENSION(kts:kte ,nchem) :: chem1 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 @@ -1047,7 +1047,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF (mix_chem ) then + IF ( rrfs_smoke .and. mix_chem ) then do ic = 1,ndvel vd1(ic) = vdep(i,ic) !is this correct???? chem1(kts,ic) = chem3d(i,kts,ic) @@ -1357,7 +1357,7 @@ SUBROUTINE mynn_bl_driver( & &frp(i), & &fire_turb ) - IF ( PRESENT(chem3d) ) THEN + IF ( rrfs_smoke ) THEN DO ic = 1,nchem DO k = kts,kte chem3d(i,k,ic) = chem1(k,ic) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 744a07e51..a5a1d9240 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -161,7 +161,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, fire_turb, nchem, ndvel, & + & chem3d, frp, mix_chem, rrfs_smoke, fire_turb, nchem, ndvel, & & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) @@ -290,7 +290,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !smoke/chem arrays real(kind_phys), dimension(:), intent(inout) :: frp - logical, intent(in) :: mix_chem, fire_turb + logical, intent(in) :: mix_chem, fire_turb, rrfs_smoke real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind=kind_phys), dimension(im) :: emis_ant_no real(kind=kind_phys), dimension(im,ndvel) :: vdep @@ -720,6 +720,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & Chem3d=chem3d,Vdep=vdep, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & & mix_chem=mix_chem,fire_turb=fire_turb, & + & rrfs_smoke=rrfs_smoke, & !----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index 01e8e1d9e..33f97113f 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1359,6 +1359,13 @@ type = real kind = kind_phys intent = inout +[rrfs_smoke] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_smoke collection (default off) + units = flag + dimensions = () + type = logical + intent = in [mix_chem] standard_name = do_planetary_boundary_layer_smoke_mixing long_name = flag for rrfs smoke mynn tracer mixing From 1a70737a39d57b525cf1e73604f203a6c6dc7b6e Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Mon, 16 May 2022 14:33:23 -0600 Subject: [PATCH 37/37] Correct argument passing within mynn edmf --- physics/module_bl_mynn.F90 | 97 +++++++++++++++++++----------------- physics/mynnedmf_wrapper.F90 | 5 +- 2 files changed, 54 insertions(+), 48 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 50685b403..8ffd8040c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -430,7 +430,8 @@ SUBROUTINE mynn_bl_driver( & &spp_pbl,pattern_spp_pbl, & &RTHRATEN, & &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA & + &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_OZONE & &,IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE) @@ -455,7 +456,7 @@ SUBROUTINE mynn_bl_driver( & REAL, INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA + FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke @@ -474,61 +475,65 @@ SUBROUTINE mynn_bl_driver( & ! closure : <= 2.5; Level 2.5 ! 2.5< and <3; Level 2.6 ! = 3; Level 3 + +! SGT: Changed this to use assumed shape arrays (dimension(:,:,:)) with no "optional" arguments +! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs +! on Cheyenne with the GNU compiler. REAL, INTENT(in) :: delt - REAL, DIMENSION(IMS:IME), INTENT(in) :: dx - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz, & + REAL, DIMENSION(:), INTENT(in) :: dx + REAL, DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: & + REAL, DIMENSION(:,:), 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, & + REAL, DIMENSION(:,:), INTENT(in):: ozone + REAL, DIMENSION(:), INTENT(in) :: xland,ust, & &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE + REAL, DIMENSION(:,:), INTENT(inout) :: DOZONE - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN + REAL, DIMENSION(:,:), INTENT(in) :: RTHRATEN - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & + REAL, DIMENSION(:,:), INTENT(out) :: & &exch_h,exch_m !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D ! REAL, DIMENSION(IMS:IME,KMS:KME) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(IMS:IME), INTENT(inout) :: Pblh,rmol + REAL, DIMENSION(:), INTENT(inout) :: Pblh,rmol REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(IMS:IME), INTENT(OUT) :: & + REAL, DIMENSION(:), INTENT(OUT) :: & &maxmf - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), INTENT(inout) :: & &el_pbl - REAL, DIMENSION(IMS:IME,KMS:KME), optional, INTENT(out) :: & + 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 - REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D + REAL, DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + REAL, DIMENSION(:,:), 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 @@ -586,7 +591,7 @@ SUBROUTINE mynn_bl_driver( & ! Stochastic fields INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl + REAL, DIMENSION( :, :), INTENT(IN) ::pattern_spp_pbl REAL, DIMENSION(KTS:KTE) ::rstoch_col ! Substepping TKE @@ -736,7 +741,7 @@ SUBROUTINE mynn_bl_driver( & QC_BL1D(k)=QC_BL(i,k) QI_BL1D(k)=QI_BL(i,k) ENDIF - IF (PRESENT(sqi3D) .AND. FLAG_QI ) THEN + IF (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) & @@ -920,7 +925,7 @@ SUBROUTINE mynn_bl_driver( & dqnwfa1(k)=0.0 dqnifa1(k)=0.0 dozone1(k)=0.0 - IF(PRESENT(sqi3D) .AND. FLAG_QI)THEN + IF(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) @@ -963,27 +968,27 @@ SUBROUTINE mynn_bl_driver( & thetav(k)=th1(k)*(1.+0.608*sqv(k)) thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) - IF (PRESENT(qni) .AND. FLAG_QNI ) THEN + IF (FLAG_QNI ) THEN qni1(k)=qni(i,k) ELSE qni1(k)=0.0 ENDIF - IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN + IF (FLAG_QNC ) THEN qnc1(k)=qnc(i,k) ELSE qnc1(k)=0.0 ENDIF - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN + IF (FLAG_QNWFA ) THEN qnwfa1(k)=qnwfa(i,k) ELSE qnwfa1(k)=0.0 ENDIF - IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN + IF (FLAG_QNIFA ) THEN qnifa1(k)=qnifa(i,k) ELSE qnifa1(k)=0.0 ENDIF - IF (PRESENT(ozone)) THEN + IF (FLAG_OZONE) THEN ozone1(k)=ozone(i,k) ELSE ozone1(k)=0.0 @@ -1344,7 +1349,7 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) - IF ( mix_chem ) THEN + IF ( rrfs_smoke .and. mix_chem ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1357,13 +1362,11 @@ SUBROUTINE mynn_bl_driver( & &frp(i), & &fire_turb ) - IF ( rrfs_smoke ) THEN - DO ic = 1,nchem - DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) - ENDDO + DO ic = 1,nchem + DO k = kts,kte + chem3d(i,k,ic) = chem1(k,ic) ENDDO - ENDIF + ENDDO ENDIF CALL retrieve_exchange_coeffs(kts,kte,& @@ -1378,22 +1381,22 @@ SUBROUTINE mynn_bl_driver( & 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) + IF (FLAG_QC) RQCBLTEN(i,k)=dqc1(k) + IF (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. + IF (FLAG_QC) RQCBLTEN(i,k)=0. + IF (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) + IF (FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) + IF (FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) + IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) + IF (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. + IF (FLAG_QNC) RQNCBLTEN(i,k)=0. + IF (FLAG_QNI) RQNIBLTEN(i,k)=0. + IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=0. + IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=0. ENDIF DOZONE(i,k)=DOZONE1(k) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index a5a1d9240..5917145fe 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -225,7 +225,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_mixscalars=1 LOGICAL :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QNWFA, FLAG_QNIFA + & FLAG_QNWFA, FLAG_QNIFA, FLAG_OZONE ! Define locally until needed from CCPP LOGICAL, PARAMETER :: cycling = .false. INTEGER, PARAMETER :: param_first_scalar = 1 @@ -389,6 +389,8 @@ SUBROUTINE mynnedmf_wrapper_run( & t3d(i,:) ) enddo + FLAG_OZONE = ntoz>0 + ! Assign variables for each microphysics scheme if (imp_physics == imp_physics_wsm6) then ! WSM6 @@ -757,6 +759,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input + & FLAG_OZONE=FLAG_OZONE, & !input & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input