diff --git a/CODEOWNERS b/CODEOWNERS index cf7a886aa0..1ac1dbe7c6 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -1,138 +1,9 @@ -######################################################################## - -# CODEOWNERS RULES (syntax guide is at end of file) - -# Default codeowners for files that don't have specific owners: - -* @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - - -# The following lines are from the CCPP Primary Schemes Points of Contact -# 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 -physics/sascnvn.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_ntiedtke* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rascnv.* @SMoorthi-emc @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/samfdeepcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfshalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfaerosols.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/unified_ugwp* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/ugwp_driver_v0.F @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/drag_suite.* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gwdc.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gwdps.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gfdl_fv_sat_adj.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/multi_gases.F90 @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/mp_fer_hires.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/precpd.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gscond.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/ozphys* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/satmedmfvdif.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/satmedmfvdifq.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbl.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscu.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbltq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscuq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shinhongvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/ysuvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_BL_MYJPBL.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYJPBL_wrapper.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_bl_mynn.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYNNPBL_wrapper.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gcm_shoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/moninshoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rte-rrtmgp @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radiation_tools.* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_lw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_sw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radlw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radlw_datatb.f @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_datatb.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rayleigh_damp.* @yangfanglin @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/flake* @YihuaWu-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_drv.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sflx.f @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/surface_perturbation.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/*noahmp* @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/namelist_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/set_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_sf_ruclsm.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_soil_pre.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_drv_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/date_def.f @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/*nst* @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_ocean.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_diff.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/h2ophys.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -######################################################################## - # Lines starting with '#' are comments. # Each line is a file pattern followed by one or more owners. # These owners will be the default owners for everything in the repo. #* @defunkt +* @SamuelTrahanNOAA @tanyasmirnova @christinaholtNOAA @joeolson42 @hannahcbarnes @mdtoyNOAA @haiqinli @zhanglikate @middlecoff # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners diff --git a/physics/GFS_DCNV_generic_post.F90 b/physics/GFS_DCNV_generic_post.F90 index 51a2281222..7de8414f8d 100644 --- a/physics/GFS_DCNV_generic_post.F90 +++ b/physics/GFS_DCNV_generic_post.F90 @@ -15,7 +15,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, & cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac,clw, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrac,clw, & satmedmf, trans_trac, errmsg, errflg) @@ -45,7 +45,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, & index_of_x_wind, index_of_y_wind, ntqv integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac + ntgnc, nthl, nthnc, nthv, ntgv, ntrac real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -112,7 +112,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & - n /= ntgv .and. n /= ntsigma) then + n /= ntgv ) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_dcnv) if(idtend>0) then diff --git a/physics/GFS_DCNV_generic_post.meta b/physics/GFS_DCNV_generic_post.meta index 8428752ce0..9fbc96f745 100644 --- a/physics/GFS_DCNV_generic_post.meta +++ b/physics/GFS_DCNV_generic_post.meta @@ -356,13 +356,6 @@ dimensions = () type = logical intent = in -[ntsigma] - standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array - long_name = tracer index of updraft_area_fraction - units = index - dimensions = () - type = integer - intent = in [ntcw] standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array long_name = tracer index for cloud condensate (or liquid water) diff --git a/physics/GFS_DCNV_generic_pre.F90 b/physics/GFS_DCNV_generic_pre.F90 index b31daf5d66..e4eed29c9d 100644 --- a/physics/GFS_DCNV_generic_pre.F90 +++ b/physics/GFS_DCNV_generic_pre.F90 @@ -13,7 +13,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc gu0, gv0, gt0, gq0, nsamftrac, ntqv, & save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv,ntsigma, & + ntgnc, nthl, nthnc, nthv, ntgv, & cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) @@ -22,7 +22,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc implicit none integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv,ntsigma + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 @@ -68,7 +68,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & - n /= ntgv .and. n/= ntsigma) then + n /= ntgv ) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_dcnv)>0) then save_q(:,:,n) = clw(:,:,tracers) @@ -87,4 +87,4 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc end subroutine GFS_DCNV_generic_pre_run - end module GFS_DCNV_generic_pre + end module GFS_DCNV_generic_pre \ No newline at end of file diff --git a/physics/GFS_DCNV_generic_pre.meta b/physics/GFS_DCNV_generic_pre.meta index ee20509260..e1cf1b0228 100644 --- a/physics/GFS_DCNV_generic_pre.meta +++ b/physics/GFS_DCNV_generic_pre.meta @@ -169,13 +169,6 @@ dimensions = () type = logical intent = in -[ntsigma] - standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array - long_name = tracer index of updraft_area_fraction - units = index - dimensions = () - type = integer - intent = in [ntcw] standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array long_name = tracer index for cloud condensate (or liquid water) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index b7e65bc8b5..58af023e14 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -26,12 +26,11 @@ subroutine GFS_MP_generic_post_run( totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, pwat, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & - dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & - fh_dfi_radar,index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, prevsq, & - errmsg, errflg) + dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d, lssav, num_dfi_radar, fh_dfi_radar, & + index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, errmsg, errflg) ! use machine, only: kind_phys - use calpreciptype_mod, only: calpreciptype + implicit none integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar @@ -81,8 +80,7 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: diceprv real(kind=kind_phys), dimension(:), intent(inout) :: dsnowprv real(kind=kind_phys), dimension(:), intent(inout) :: dgraupelprv - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdt_qmicro - real(kind=kind_phys), dimension(:,:), intent(inout) :: prevsq + real(kind=kind_phys), intent(in) :: dtp ! CCPP error handling @@ -398,13 +396,6 @@ subroutine GFS_MP_generic_post_run( pwat(i) = pwat(i) * onebg enddo - if(progsigma)then - do k = 1, levs - do i=1, im - prevsq(i,k) = gq0(i,k,1) - enddo - enddo - endif end subroutine GFS_MP_generic_post_run !> @} diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 5216b71579..cf77c77dad 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -738,22 +738,6 @@ dimensions = () type = logical intent = in -[dqdt_qmicro] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics - long_name = moisture tendency due to microphysics - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[prevsq] - standard_name = specific_humidity_on_previous_timestep - long_name = specific_humidity_on_previous_timestep - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [lssav] standard_name = flag_for_diagnostics long_name = logical flag for storing diagnostics diff --git a/physics/GFS_SCNV_generic_post.F90 b/physics/GFS_SCNV_generic_post.F90 index 0b38ff0815..adc8fc1c80 100644 --- a/physics/GFS_SCNV_generic_post.F90 +++ b/physics/GFS_SCNV_generic_post.F90 @@ -14,7 +14,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & rainc, cnvprcp, cnvprcpb, cnvw_phy_f3d, cnvc_phy_f3d, & dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & index_of_process_scnv, ntqv, flag_for_scnv_generic_tend, & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntsigma, & + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & imfshalcnv, imfshalcnv_sas, imfshalcnv_samf, ntrac, & cscnv, satmedmf, trans_trac, ras, errmsg, errflg) @@ -23,7 +23,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & implicit none integer, intent(in) :: im, levs, nn, ntqv, nsamftrac - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntsigma,ntrac + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac 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 @@ -103,7 +103,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. n /= ntsigma) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_scnv) if(idtend>0) then diff --git a/physics/GFS_SCNV_generic_post.meta b/physics/GFS_SCNV_generic_post.meta index bf6ba394fb..ab9f515628 100644 --- a/physics/GFS_SCNV_generic_post.meta +++ b/physics/GFS_SCNV_generic_post.meta @@ -335,13 +335,6 @@ dimensions = () type = logical intent = in -[ntsigma] - standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array - long_name = tracer index of updraft_area_fraction - units = index - dimensions = () - type = integer - intent = in [ntcw] standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array long_name = tracer index for cloud condensate (or liquid water) diff --git a/physics/GFS_SCNV_generic_pre.F90 b/physics/GFS_SCNV_generic_pre.F90 index d89a333020..0740127bd1 100644 --- a/physics/GFS_SCNV_generic_pre.F90 +++ b/physics/GFS_SCNV_generic_pre.F90 @@ -11,14 +11,14 @@ module GFS_SCNV_generic_pre subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, gq0, & save_u, save_v, save_t, save_q, ntqv, nsamftrac, flag_for_scnv_generic_tend, & dtidx, index_of_process_scnv, ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, & - ntsigma, cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) + cscnv, satmedmf, trans_trac, ras, ntrac, clw, errmsg, errflg) use machine, only: kind_phys implicit none integer, intent(in) :: im, levs, ntqv, nsamftrac, index_of_process_scnv, dtidx(:,:) - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc, ntsigma,ntrac + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac logical, intent(in) :: ldiag3d, qdiag3d, flag_for_scnv_generic_tend real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 @@ -49,7 +49,7 @@ subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. n /= ntsigma) then + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_scnv)>0) then save_q(:,:,n) = clw(:,:,tracers) @@ -70,4 +70,4 @@ subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, gu0, gv0, gt0, end subroutine GFS_SCNV_generic_pre_run - end module GFS_SCNV_generic_pre + end module GFS_SCNV_generic_pre \ No newline at end of file diff --git a/physics/GFS_SCNV_generic_pre.meta b/physics/GFS_SCNV_generic_pre.meta index eccd547a1c..07af85a70e 100644 --- a/physics/GFS_SCNV_generic_pre.meta +++ b/physics/GFS_SCNV_generic_pre.meta @@ -162,13 +162,6 @@ dimensions = () type = logical intent = in -[ntsigma] - standard_name = index_of_updraft_area_fraction_in_tracer_concentration_array - long_name = tracer index of updraft_area_fraction - units = index - dimensions = () - type = integer - intent = in [ntcw] standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array long_name = tracer index for cloud condensate (or liquid water) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5e64192565..3230ef4335 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -624,6 +624,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%fluxr_n ', Diag%fluxr(:,n)) !end do call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%srunoff ', Diag%srunoff) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbs ', Diag%evbs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcw ', Diag%evcw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sbsno ', Diag%sbsno) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbsa ', Diag%evbsa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcwa ', Diag%evcwa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%snohfa ', Diag%snohfa) @@ -1204,8 +1207,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_ice ', Interstitial%evap_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_land ', Interstitial%evap_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_water ', Interstitial%evap_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evbs ', Interstitial%evbs ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evcw ', Interstitial%evcw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ext_diag_thompson_reset', Interstitial%ext_diag_thompson_reset) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faerlw ', Interstitial%faerlw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faersw ', Interstitial%faersw ) @@ -1302,7 +1303,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_tcp ', Interstitial%save_tcp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_u ', Interstitial%save_u ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_v ', Interstitial%save_v ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sbsno ', Interstitial%sbsno ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbfc ', Interstitial%scmpsw%uvbfc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbf0 ', Interstitial%scmpsw%uvbf0 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%nirbm ', Interstitial%scmpsw%nirbm ) @@ -1315,6 +1315,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmafrac ', Interstitial%sigmafrac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) @@ -1327,7 +1330,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_land ', Interstitial%tprcp_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_water ', Interstitial%tprcp_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans ', Interstitial%trans ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Interstitial%trans ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) @@ -1341,6 +1344,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vdftra ', Interstitial%vdftra ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegf1d ', Interstitial%vegf1d ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index d05f02dae2..6da20a4256 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -20,7 +20,7 @@ module GFS_rrtmg_pre subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & n_var_lndp, imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, & npdf3d, ncnvcld3d, ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & - ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, ntsmoke, ntdust, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, & ntss3, ntss4, ntss5, ntsu, ntbcb, ntbcl, ntocb, ntocl, ntchm, & @@ -44,7 +44,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & 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, rrfs_smoke_band, errmsg, errflg) + spp_wts_rad, spp_rad, errmsg, errflg) use machine, only: kind_phys @@ -92,6 +92,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & ntcw, ntiw, ntlnc, ntinc, & ntrnc, ntsnc,ntccn, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntsmoke, ntdust, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & kdt, imp_physics, & @@ -113,8 +114,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & iovr_exprand, & ! Flag for exponential-random cloud overlap method idcor_con, & idcor_hogan, & - idcor_oreopoulos, & - rrfs_smoke_band ! Band number for rrfs-smoke dust and smoke + idcor_oreopoulos integer, intent(in) :: ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, ntss3, & ntss4, ntss5, ntsu, ntbcb, ntbcl, ntocb, ntocl, ntchm @@ -614,6 +614,19 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & !check print *,' in grrad : calling setaer ' +!>--- add smoke and dust --- + if (aero_dir_fdb) then + do k=1,lmk + do i=1,im + aer_nm(i,k,1 )=aer_nm(i,k,1 )+qgrs(i,k,ntdust )*0.11 + aer_nm(i,k,2 )=aer_nm(i,k,1 )+qgrs(i,k,ntdust )*0.89 + aer_nm(i,k,12)=aer_nm(i,k,12)+qgrs(i,k,ntsmoke)*0.01 + aer_nm(i,k,14)=aer_nm(i,k,14)+qgrs(i,k,ntsmoke)*0.99 + enddo + enddo + endif +!>---------------------------- + !> - Initialize mass mixing ratio of aerosols from NASA GOCART or NASA MERRA-2 if (ntchm>0 .and. iaermdl==2) then do k=1,levs @@ -657,16 +670,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & enddo enddo - !> - Add 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 - ! 550nm (~18000/cm) - 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 - 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 63ab11d3e8..804b3a1399 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -219,6 +219,20 @@ dimensions = () type = integer intent = in +[ntsmoke] + 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_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -1365,13 +1379,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke_band] - standard_name = index_of_shortwave_band_affected_by_smoke - 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 diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 32104b7f82..48882ef524 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -195,20 +195,11 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic ! ! SGS clouds present, use cloud-fraction modified to include sgs clouds. ! - if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then - ! MYNN sub-grid cloud fraction. - if (do_mynnedmf) then - ! If rain/snow present, use GFDL MP cloud-fraction... - 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 - ! GF sub-grid cloud fraction. - else - ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... - if (qci_conv(iCol,iLay) <= 0.) then - cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) - endif - endif + if (imfdeepcnv==imfdeepcnv_gf .and. kdt>1) then + ! If no convective cloud condensate present, use GFDL MP cloud-fraction.... + if (qci_conv(iCol,iLay) <= 0.) then + cld_frac(iCol,iLay) = tracer(iCol,iLay,i_cldtot) + endif ! ! No SGS clouds, use GFDL MP cloud-fraction... ! diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 new file mode 100644 index 0000000000..d9d7c37f64 --- /dev/null +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -0,0 +1,184 @@ +! ######################################################################################## +! This module contains the interface between the GFDL macrophysics and the RRTMGP radiation +! schemes. Only compatable with Model%imp_physics = Model%imp_physics_gfdl +! ######################################################################################## +module GFS_rrtmgp_gfdlmp_pre + use machine, only: kind_phys + use radiation_tools, only: check_error_msg + use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp + use rrtmgp_lw_cloud_optics, only: radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& + radice_lwr => radice_lwrLW, radice_upr => radice_uprLW + + ! Parameters + real(kind_phys), parameter :: & + reliq_def = 10.0 , & ! Default liq radius to 10 micron (used when effr_in=F) + reice_def = 50.0, & ! Default ice radius to 50 micron (used when effr_in=F) + rerain_def = 1000.0, & ! Default rain radius to 1000 micron (used when effr_in=F) + resnow_def = 250.0, & ! Default snow radius to 250 micron (used when effr_in=F) + reice_min = 10.0, & ! Minimum ice size allowed by GFDL MP scheme + reice_max = 150.0 ! Maximum ice size allowed by GFDL MP scheme + ! NOTE: When using RRTMGP cloud-optics, the min/max particle size allowed are imported + ! from initialization. + + public GFS_rrtmgp_gfdlmp_pre_init, GFS_rrtmgp_gfdlmp_pre_run, GFS_rrtmgp_gfdlmp_pre_finalize + +contains + ! ###################################################################################### + ! ###################################################################################### + subroutine GFS_rrtmgp_gfdlmp_pre_init() + end subroutine GFS_rrtmgp_gfdlmp_pre_init + + ! ###################################################################################### + ! ###################################################################################### +!! \section arg_table_GFS_rrtmgp_gfdlmp_pre_run +!! \htmlinclude GFS_rrtmgp_gfdlmp_pre_run.html +!! + subroutine GFS_rrtmgp_gfdlmp_pre_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & + i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, doSWrad, doLWrad, effr_in, kdt, & + do_mynnedmf, p_lev, p_lay, tv_lay, effrin_cldliq, effrin_cldice, effrin_cldrain, & + effrin_cldsnow, tracer, con_g, con_rd, doGP_cldoptics_PADE, doGP_cldoptics_LUT, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, errmsg, errflg) + implicit none + + ! Inputs + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nLev, & ! Number of vertical layers + ncnd, & ! Number of cloud condensation types. + nTracers, & ! Number of tracers from model. + i_cldliq, & ! Index into tracer array for cloud liquid. + i_cldice, & ! Index into tracer array for cloud ice. + i_cldrain, & ! Index into tracer array for cloud rain. + i_cldsnow, & ! Index into tracer array for cloud snow. + i_cldgrpl, & ! Index into tracer array for cloud groupel. + i_cldtot, & ! Index into tracer array for cloud total amount. + kdt ! Current forecast iteration + logical, intent(in) :: & + doSWrad, & ! Call SW radiation? + doLWrad, & ! Call LW radiation + effr_in, & ! Provide hydrometeor radii from macrophysics? + do_mynnedmf, & ! Flag to activate MYNN-EDMF + doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) + doGP_cldoptics_PADE ! (PADE approximation) + real(kind_phys), intent(in) :: & + con_g, & ! Physical constant: gravitational constant + con_rd ! Physical constant: gas-constant for dry air + real(kind_phys), dimension(:,:), intent(in) :: & + tv_lay, & ! Virtual temperature (K) + p_lay, & ! Pressure at model-layers (Pa) + effrin_cldliq, & ! Effective radius for liquid cloud-particles (microns) + effrin_cldice, & ! Effective radius for ice cloud-particles (microns) + effrin_cldrain, & ! Effective radius for rain cloud-particles (microns) + effrin_cldsnow ! Effective radius for snow cloud-particles (microns) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev ! Pressure at model-level interfaces (Pa) + real(kind_phys), dimension(:,:,:),intent(in) :: & + tracer ! Cloud condensate amount in layer by type () + + ! Outputs + real(kind_phys), dimension(:,:),intent(inout) :: & + cld_frac, & ! Total cloud fraction + cld_lwp, & ! Cloud liquid water path + cld_reliq, & ! Cloud liquid effective radius + cld_iwp, & ! Cloud ice water path + cld_reice, & ! Cloud ice effecive radius + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain, & ! Cloud rain effective radius + precip_frac ! Precipitation fraction + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + + ! Local variables + real(kind_phys) :: tem1,pfac + real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate + integer :: iCol,iLay,l,ncndl + real(kind_phys), dimension(nCol,nLev) :: deltaP,deltaZ + + if (.not. (doSWrad .or. doLWrad)) return + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Test inputs + if (ncnd .ne. 5) then + errmsg = 'Incorrect number of cloud condensates provided' + errflg = 1 + call check_error_msg('GFS_rrtmgp_gfdlmp_pre_run',errmsg) + return + endif + + ! Initialize outputs + cld_reliq(:,:) = reliq_def + cld_reice(:,:) = reice_def + cld_rerain(:,:) = rerain_def + cld_resnow(:,:) = resnow_def + + ! #################################################################################### + ! Pull out cloud information for GFDL MP scheme. + ! #################################################################################### + ! Condensate + cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water + cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water + cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water + cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel + tracer(1:nCol,1:nLev,i_cldgrpl) + + ! Cloud water path (g/m2) + deltaP = abs(p_lev(:,2:nLev+1)-p_lev(:,1:nLev))/100. + do iLay = 1, nLev + do iCol = 1, nCol + ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) + tem1 = (1.0e5/con_g) * deltaP(iCol,iLay) + cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1) + cld_iwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,2) * tem1) + cld_rwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,3) * tem1) + cld_swp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,4) * tem1) + enddo + enddo + + ! Particle size + do iLay = 1, nLev + do iCol = 1, nCol + ! Use radii provided from the macrophysics + if (effr_in) then + cld_reliq(iCol,iLay) = effrin_cldliq(iCol,iLay) + cld_reice(iCol,iLay) = max(reice_min, min(reice_max,effrin_cldice(iCol,iLay))) + cld_rerain(iCol,iLay) = effrin_cldrain(iCol,iLay) + cld_resnow(iCol,iLay) = effrin_cldsnow(iCol,iLay) + endif + enddo + enddo + + ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from + ! 2.5 - 21.5 microns for liquid clouds, + ! 10 - 180 microns for ice-clouds + if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + where(cld_reliq .lt. radliq_lwr) cld_reliq = radliq_lwr + where(cld_reliq .gt. radliq_upr) cld_reliq = radliq_upr + where(cld_reice .lt. radice_lwr) cld_reice = radice_lwr + where(cld_reice .gt. radice_upr) cld_reice = radice_upr + endif + + ! Cloud-fraction. For mynnedmf, cld_frac is already defined in sgscloudradpre. + if (do_mynnedmf .and. kdt .gt. 1) then + !already set in sgscloudradpre + else + cld_frac(1:nCol,1:nLev) = tracer(1:nCol,1:nLev,i_cldtot) + endif + + ! Precipitation fraction (Hack. For now use cloud-fraction) + precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) + + end subroutine GFS_rrtmgp_gfdlmp_pre_run + + ! ######################################################################################### + ! ######################################################################################### + subroutine GFS_rrtmgp_gfdlmp_pre_finalize() + end subroutine GFS_rrtmgp_gfdlmp_pre_finalize +end module GFS_rrtmgp_gfdlmp_pre diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 index 4efcf7a026..7c2e53aeab 100644 --- a/physics/GFS_suite_interstitial_3.F90 +++ b/physics/GFS_suite_interstitial_3.F90 @@ -9,13 +9,10 @@ module GFS_suite_interstitial_3 !! \htmlinclude GFS_suite_interstitial_3_run.html !! subroutine GFS_suite_interstitial_3_run (otsptflag, & - im, levs, nn, cscnv,imfshalcnv, imfdeepcnv, & - imfshalcnv_samf, imfdeepcnv_samf,progsigma, & - first_time_step, restart, & + im, levs, nn, cscnv, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & - xlon, xlat, gt0, gq0, sigmain,sigmaout,qmicro, & - imp_physics, imp_physics_mg, & + xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & @@ -36,9 +33,8 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & imp_physics_nssl, me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver - logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras, progsigma - logical, intent(in ) :: first_time_step, restart - integer, intent(in ) :: imfshalcnv, imfdeepcnv, imfshalcnv_samf,imfdeepcnv_samf + logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras + integer, intent(in) :: ntinc, ntlnc logical, intent(in) :: ldiag3d, qdiag3d integer, dimension(:,:), intent(in) :: dtidx @@ -52,8 +48,6 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & real(kind=kind_phys), intent(in ), dimension(:,:) :: gt0 real(kind=kind_phys), intent(in ), dimension(:,:,:) :: gq0 - real(kind=kind_phys), intent(inout ), dimension(:,:) :: sigmain - real(kind=kind_phys), intent(inout ), dimension(:,:) :: sigmaout,qmicro real(kind=kind_phys), intent(inout), dimension(:,:) :: rhc, save_qc ! save_qi is not allocated for Zhao-Carr MP real(kind=kind_phys), intent(inout), dimension(:,:) :: save_qi @@ -79,27 +73,6 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & errmsg = '' errflg = 0 - ! In case of using prognostic updraf area fraction, initialize area fraction here - ! since progsigma_calc is called from both deep and shallow schemes. - if(((imfshalcnv == imfshalcnv_samf) .or. (imfdeepcnv == imfdeepcnv_samf)) & - .and. progsigma)then - if(first_time_step .and. .not. restart)then - do k=1,levs - do i=1,im - sigmain(i,k)=0.0 - sigmaout(i,k)=0.0 - qmicro(i,k)=0.0 - enddo - enddo - endif - do k=1,levs - do i=1,im - sigmaout(i,k)=0.0 - enddo - enddo - endif - - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then tracers = 2 do n=2,ntrac @@ -227,4 +200,4 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & end subroutine GFS_suite_interstitial_3_run - end module GFS_suite_interstitial_3 + end module GFS_suite_interstitial_3 \ No newline at end of file diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta index fe52a1adcc..22a11d0ea1 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/GFS_suite_interstitial_3.meta @@ -43,55 +43,6 @@ dimensions = () type = logical intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfshalcnv] - standard_name = control_for_shallow_convection_scheme - long_name = flag for mass-flux shallow convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfshalcnv_samf] - standard_name = identifier_for_scale_aware_mass_flux_shallow_convection - long_name = flag for SAMF shallow convection scheme - units = flag - dimensions = () - type = integer - intent = in -[progsigma] - standard_name = do_prognostic_updraft_area_fraction - long_name = flag for prognostic sigma in cumuls scheme - units = flag - dimensions = () - type = logical - intent = in -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in -[restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in [satmedmf] standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL long_name = flag for scale-aware TKE moist EDMF PBL scheme @@ -222,30 +173,6 @@ type = real kind = kind_phys intent = in -[sigmain] - standard_name = prognostic_updraft_area_fraction_in_convection - long_name = convective updraft area fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[sigmaout] - standard_name = updraft_area_fraction_updated_by_physics - long_name = convective updraft area fraction updated by physics - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[qmicro] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics - long_name = moisture tendency due to microphysics - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index 2166e1b5c6..b7cb8d6eb2 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -1,8 +1,6 @@ !>\file calpreciptype.f90 !! This file contains the subroutines that calculates dominant precipitation type. -module calpreciptype_mod -contains !>\ingroup gfs_calpreciptype !! Foure algorithms are called to calculate dominant precipitation type, and the !!tallies are sumed in calwxt_dominant(). @@ -27,18 +25,17 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & ! -------------------------------------------------------------------- use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe use physcons - use machine , only : kind_phys !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! - real(kind=kind_phys), parameter :: pthresh = 0.0, oneog = 1.0/con_g + real, parameter :: pthresh = 0.0, oneog = 1.0/con_g integer,parameter :: nalg = 5 ! ! declare variables. ! integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1 - real(kind=kind_phys),intent(in) :: xlat(im),xlon(im) - real(kind=kind_phys),intent(in) :: randomno(ix,nrcm) + real,intent(in) :: xlat(im),xlon(im) + real,intent(in) :: randomno(ix,nrcm) real(kind=kind_phys),dimension(im), intent(in) :: prec,tskin real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii @@ -221,9 +218,8 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & !! This subroutine computes precipitation type using a decision tree approach that uses !! variables such as integrated wet bulb temperatue below freezing and lowest layer !! temperature (Baldwin et al. 1994 \cite baldwin_et_al_1994) - subroutine calwxt(lm,lp1,t,q,pmid,pint, & - d608,rog,epsq,zint,iwx,twet) - use machine , only : kind_phys + subroutine calwxt(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,iwx,twet) ! ! file: calwxt.f ! written: 11 november 1993, michael baldwin @@ -249,10 +245,10 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! t,q,pmid,htm,lmh,zint ! integer,intent(in) :: lm,lp1 - real(kind=kind_phys),dimension(lm),intent(in) :: t,q,pmid,twet - real(kind=kind_phys),dimension(lp1),intent(in) :: zint,pint + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: zint,pint integer,intent(out) :: iwx - real(kind=kind_phys),intent(in) :: d608,rog,epsq + real,intent(in) :: d608,rog,epsq ! output: @@ -266,10 +262,10 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! ! internal: ! -! real(kind=kind_phys), allocatable :: twet(:) - real(kind=kind_phys), parameter :: d00=0.0 +! real, allocatable :: twet(:) + real, parameter :: d00=0.0 integer karr,licee - real(kind=kind_phys) tcold,twarm + real tcold,twarm ! subroutines called: ! wetbulb @@ -284,7 +280,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! integer l,lice,iwrml,ifrzl - real(kind=kind_phys) psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & surfw,surfc,dzkl,area1,pintk1,pintk2,pm150,pkl,tkl,qkl ! allocate ( twet(lm) ) @@ -488,28 +484,27 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! use params_mod ! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - use machine , only : kind_phys implicit none ! - real(kind=kind_phys),parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & + real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & & emelt=0.045,rlim=0.04,slim=0.85 - real(kind=kind_phys),parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now + real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now ! integer*4 i, k1, lll, k2, toodry ! - real(kind=kind_phys) xxx ,mye, icefrac + real xxx ,mye, icefrac integer, intent(in) :: lm,lp1 - real(kind=kind_phys),dimension(lm), intent(in) :: t,q,pmid,rh,td - real(kind=kind_phys),dimension(lp1),intent(in) :: pint + real,dimension(lm), intent(in) :: t,q,pmid,rh,td + real,dimension(lp1),intent(in) :: pint integer, intent(out) :: ptyp ! - real(kind=kind_phys),dimension(lm) :: tq,pq,rhq,twq + real,dimension(lm) :: tq,pq,rhq,twq ! integer j,l,lev,ii - real(kind=kind_phys) rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & + real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & rhavg,dtavg,dpk,ptw,pbot -! real(kind=kind_phys) b,qtmp,rate,qc -! +! real b,qtmp,rate,qc + real,external :: xmytw ! ! initialize. icefrac = -9999. @@ -524,7 +519,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! causing problems later in this subroutine ! qtmp=max(h1m12,q(l)) ! rhqtmp(lev)=qtmp/qc - rhq(lev) = rh(l) + rhq(lev) = rh(l) pq(lev) = pmid(l) * 0.01 tq(lev) = t(l) enddo @@ -756,11 +751,10 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) !-------------------------------------------------------------------------- function xmytw(t,td,p) ! - use machine , only : kind_phys implicit none ! integer*4 cflag, l - real(kind=kind_phys) f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & + real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & & de, xmytw data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ ! @@ -881,20 +875,19 @@ function xmytw(t,td,p) !! \cite bourgouin_2000. !of aes (canada) 1992 subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) - use machine , only : kind_phys implicit none ! ! input: integer,intent(in) :: lm,lp1 - real(kind=kind_phys),intent(in) :: g,rn(2) - real(kind=kind_phys),intent(in), dimension(lm) :: t, q, pmid - real(kind=kind_phys),intent(in), dimension(lp1) :: pint, zint + real,intent(in) :: g,rn(2) + real,intent(in), dimension(lm) :: t, q, pmid + real,intent(in), dimension(lp1) :: pint, zint ! ! output: integer, intent(out) :: ptype ! integer ifrzl,iwrml,l,lhiwrm - real(kind=kind_phys) pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 + real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 ! ! initialize weather type array to zero (ie, off). ! we do this since we want ptype to represent the @@ -1081,7 +1074,6 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! use params_mod ! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - use machine , only : kind_phys implicit none ! ! list of variables needed @@ -1093,9 +1085,9 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! t,q,pmid,htm,lmh,zint integer,intent(in) :: lm,lp1 - real(kind=kind_phys),dimension(lm),intent(in) :: t,q,pmid,twet - real(kind=kind_phys),dimension(lp1),intent(in) :: pint,zint - real(kind=kind_phys),intent(in) :: d608,rog,epsq + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: pint,zint + real,intent(in) :: d608,rog,epsq ! output: ! iwx - instantaneous weather type. ! acts like a 4 bit binary @@ -1107,12 +1099,12 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & integer, intent(out) :: iwx ! internal: ! - real(kind=kind_phys), parameter :: d00=0.0 + real, parameter :: d00=0.0 integer karr,licee - real(kind=kind_phys) tcold,twarm + real tcold,twarm ! integer l,lmhk,lice,iwrml,ifrzl - real(kind=kind_phys) psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & surfw,surfc,dzkl,pintk1,pintk2,pm150,qkl,tkl,pkl,area0,areap0 ! subroutines called: @@ -1321,15 +1313,14 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & ! algorithms and sums them up to give a dominant type ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - use machine , only : kind_phys implicit none ! ! input: integer,intent(in) :: nalg - real(kind=kind_phys),intent(out) :: doms,domr,domzr,domip + real,intent(out) :: doms,domr,domzr,domip integer,dimension(nalg),intent(in) :: rain,snow,sleet,freezr integer l - real(kind=kind_phys) totsn,totip,totr,totzr + real totsn,totip,totr,totzr !-------------------------------------------------------------------------- ! print* , 'into dominant' domr = 0. diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index c648d96474..4b53878ab4 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -16,9 +16,8 @@ module cires_ugwp use machine, only: kind_phys use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize - use ugwp_driver_v0 + use gwdps, only: gwdps_run - use cires_ugwp_triggers implicit none diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 index ba7483eca8..76f290e4dd 100644 --- a/physics/cires_ugwp_triggers.F90 +++ b/physics/cires_ugwp_triggers.F90 @@ -103,4 +103,3 @@ subroutine init_nazdir_v0(naz, xaz, yaz) yaz(4) =-1.0 !S endif end subroutine init_nazdir_v0 - end module cires_ugwp_triggers diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index b0af0f2a1e..531fd6dbca 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -2,7 +2,7 @@ !! module cires_ugwpv1_oro - use cires_ugwpv1_sporo + contains subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 index 769248b0ec..c5eb538394 100644 --- a/physics/cires_ugwpv1_sporo.F90 +++ b/physics/cires_ugwpv1_sporo.F90 @@ -354,4 +354,3 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & end subroutine oro_meanflow - end module cires_ugwpv1_sporo diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 61abb29a94..1912497e06 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -309,6 +309,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! these should be coming in from outside ! ! cactiv(:) = 0 +! cactiv_m(:) = 0 rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. diff --git a/physics/funcphys.f90 b/physics/funcphys.f90 index 3e81a0d5a8..8cb4b1b15c 100644 --- a/physics/funcphys.f90 +++ b/physics/funcphys.f90 @@ -260,7 +260,7 @@ module funcphys ! Language: Fortran 90 ! !$$$ - use machine,only:kind_phys,r8=>kind_dbl_prec,r4=>kind_sngl_prec + use machine,only:kind_phys use physcons implicit none private @@ -308,13 +308,6 @@ module funcphys public grkap,frkap,frkapq,frkapx public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx public gfuncphys - - interface fpvsl - module procedure fpvsl_r4, fpvsl_r8 - end interface fpvsl - interface fpvsi - module procedure fpvsi_r4, fpvsi_r8 - end interface fpvsi contains !------------------------------------------------------------------------------- !> This subroutine computes saturation vapor pressure table as a function of @@ -371,8 +364,7 @@ subroutine gpvsl !! in gpvsl(). See documentation for fpvslx() for details. Input values !! outside table range are reset to table extrema. !>\author N phillips - - elemental function fpvsl_r4(t) + elemental function fpvsl(t) !$$$ Subprogram Documentation Block ! ! Subprogram: fpvsl Compute saturation vapor pressure over liquid @@ -404,62 +396,16 @@ elemental function fpvsl_r4(t) ! !$$$ implicit none - real(r4) fpvsl_r4 - real(r4),intent(in):: t - integer jx - real(r4) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._r4),real(nxpvsl,r4)) - jx=min(xj,nxpvsl-1._r4) - fpvsl_r4=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function fpvsl_r4 - - elemental function fpvsl_r8(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsl Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsl. See documentation for fpvslx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsl is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvsl(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsl Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(r8) fpvsl_r8 - real(r8),intent(in):: t + real(krealfp) fpvsl + real(krealfp),intent(in):: t integer jx - real(r8) xj + real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._r8),real(nxpvsl,r8)) - jx=min(xj,nxpvsl-1._r8) - fpvsl_r8=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) + xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) + jx=min(xj,nxpvsl-1._krealfp) + fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function fpvsl_r8 - - - + end function !------------------------------------------------------------------------------- !> This function computes saturation vapor pressure from the temperature. !! A quadratic interpolation is done between values in a lookup table @@ -630,8 +576,7 @@ subroutine gpvsi !! computed in gpvsi(). See documentation for fpvsix() for details. !! Input values outside table range are reset to table extrema. !>\author N Phillips - - elemental function fpvsi_r4(t) + elemental function fpvsi(t) !$$$ Subprogram Documentation Block ! ! Subprogram: fpvsi Compute saturation vapor pressure over ice @@ -664,61 +609,16 @@ elemental function fpvsi_r4(t) ! !$$$ implicit none - real(r4) fpvsi_r4 - real(r4),intent(in):: t - integer jx - real(r4) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._r4),real(nxpvsi,r4)) - jx=min(xj,nxpvsi-1._r4) - fpvsi_r4=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function fpvsi_r4 - - elemental function fpvsi_r8(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsi Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsi. See documentation for fpvsix for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsi is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsi(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsi Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(r8) fpvsi_r8 - real(r8),intent(in):: t + real(krealfp) fpvsi + real(krealfp),intent(in):: t integer jx - real(r8) xj + real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._r8),real(nxpvsi,r8)) - jx=min(xj,nxpvsi-1._r8) - fpvsi_r8=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) + xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) + jx=min(xj,nxpvsi-1._krealfp) + fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function fpvsi_r8 - + end function !------------------------------------------------------------------------------- !> This function computes saturation vapor pressure from the temperature. !! A quadratic interpolation is done between values in a lookup table @@ -2475,7 +2375,7 @@ elemental subroutine stmaq(the,pk,tma,qma) !>\param[in] pk real, pressure over 1e5 Pa to the kappa power !>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg - subroutine stmax(the,pk,tma,qma) + elemental subroutine stmax(the,pk,tma,qma) !$$$ Subprogram Documentation Block ! ! Subprogram: stmax Compute moist adiabat temperature @@ -2543,7 +2443,7 @@ subroutine stmax(the,pk,tma,qma) !>\param[in] pk real, pressure over 1e5 Pa to the kappa power !>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg - subroutine stmaxg(tg,the,pk,tma,qma) + elemental subroutine stmaxg(tg,the,pk,tma,qma) !$$$ Subprogram Documentation Block ! ! Subprogram: stmaxg Compute moist adiabat temperature diff --git a/physics/hedmf.f b/physics/hedmf.f index 4b010a121d..8ce196f2c9 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -6,9 +6,6 @@ !! scheme. module hedmf - use tridi_mod - use mfpbl_mod - contains !> \section arg_table_hedmf_init Argument Table diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index 246f81654c..ee7185b4be 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -7,7 +7,6 @@ module lsm_noah use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg use namelist_soilveg - use sflx implicit none diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 99b6c2b414..f7a66f90ba 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -300,15 +300,15 @@ end subroutine lsm_ruc_finalize ! sncovr1 - real, snow cover over land (fractional) im ! ! qsurf - real, specific humidity at sfc im ! ! gflux - real, soil heat flux (w/m**2) im ! -! drain - real, subsurface runoff (m/s) im ! +! drain - real, subsurface runoff (mm/s) im ! ! evap - real, latent heat flux in kg kg-1 m s-1 im ! -! runof - real, surface runoff (m/s) im ! -! evbs - real, direct soil evaporation (m/s) im ! -! evcw - real, canopy water evaporation (m/s) im ! -! sbsno - real, sublimation/deposit from snopack (m/s) im ! +! runof - real, surface runoff (mm/s) im ! +! evbs - real, direct soil evaporation (W m-2) im ! +! evcw - real, canopy water evaporation (W m-2) im ! +! sbsno - real, sublimation/deposit from snopack (W m-2) im ! ! stm - real, total soil column moisture content (m) im ! -! trans - real, total plant transpiration (m/s) im ! -! zorl - real, surface roughness im ! +! trans - real, total plant transpiration (W m-2) im ! +! zorl - real, surface roughness (cm) im ! ! wetness - real, normalized soil wetness im ! ! ! ! ==================== end of description ===================== ! @@ -324,17 +324,17 @@ subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & imp_physics_nssl, & - & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs,& - & t1, q1, qc, stype, vtype, sigmaf, laixy, & + & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, & + & oro, sigma, zs, t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & - & rainnc, rainc, ice, snow, graupel, & - & prsl1, zf, wind, shdmin, shdmax, & + & rainnc, rainc, ice, snow, graupel, prsl1, zf, & + & wind, shdmin, shdmax, & & srflag, sfalb_lnd_bck, snoalb, & & isot, ivegsrc, fice, smcwlt2, smcref2, & & min_lakeice, min_seaice, oceanfrac, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & - & con_fvirt, & + & con_hfus, con_fvirt, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -346,13 +346,13 @@ subroutine lsm_ruc_run & ! inputs & qsurf_lnd, gflux_lnd, evap_lnd, hflx_lnd, & & runof, runoff, srunoff, drain, & & cm_lnd, ch_lnd, evbs, evcw, stm, wetness, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & ! for ice & sfcqc_ice, sfcqv_ice, & & tsurf_ice, tsnow_ice, z0rl_ice, & & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & - & cm_ice, ch_ice, snowfallac_ice, & + & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & ! --- out & rhosnf, sbsno, & @@ -375,6 +375,7 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_nssl real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d + real (kind=kind_phys), dimension(:), intent(in) :: oro, sigma real (kind=kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & @@ -390,7 +391,7 @@ subroutine lsm_ruc_run & ! inputs real (kind=kind_phys), intent(in) :: delt, min_seaice, min_lakeice real (kind=kind_phys), intent(in) :: con_cp, con_rv, con_g, & con_pi, con_rd, & - con_hvap, con_fvirt + con_hvap, con_hfus, con_fvirt logical, dimension(:), intent(in) :: flag_iter, flag_guess logical, dimension(:), intent(in) :: land, icy, use_lake @@ -432,10 +433,11 @@ subroutine lsm_ruc_run & ! inputs ! for land & sncovr1_lnd, qsurf_lnd, gflux_lnd, evap_lnd, & & cmm_lnd, chh_lnd, hflx_lnd, sbsno, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & ! for ice & sncovr1_ice, qsurf_ice, gflux_ice, evap_ice, ep1d_ice, & - & cmm_ice, chh_ice, hflx_ice, snowfallac_ice + & cmm_ice, chh_ice, hflx_ice, & + & snowfallac_ice, acsnow_ice, snowmt_ice real (kind=kind_phys), dimension(:), intent( out) :: & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & @@ -451,18 +453,18 @@ subroutine lsm_ruc_run & ! inputs ! --- locals: real (kind=kind_phys), dimension(im) :: rho, & - & q0, qs1, albbcksol, & + & q0, qs1, albbcksol, srunoff_old, runoff_old, & & tprcp_old, srflag_old, sr_old, canopy_old, wetness_old, & ! for land & weasd_lnd_old, snwdph_lnd_old, tskin_lnd_old, & - & tsnow_lnd_old, snowfallac_lnd_old, & + & tsnow_lnd_old, snowfallac_lnd_old, acsnow_lnd_old, & & sfcqv_lnd_old, sfcqc_lnd_old, z0rl_lnd_old, & - & sncovr1_lnd_old, & + & sncovr1_lnd_old,snowmt_lnd_old, & ! for ice & weasd_ice_old, snwdph_ice_old, tskin_ice_old, & - & tsnow_ice_old, snowfallac_ice_old, & + & tsnow_ice_old, snowfallac_ice_old, acsnow_ice_old, & & sfcqv_ice_old, sfcqc_ice_old, z0rl_ice_old, & - & sncovr1_ice_old + & sncovr1_ice_old,snowmt_ice_old !-- local spp pattern array real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm @@ -480,6 +482,7 @@ subroutine lsm_ruc_run & ! inputs real (kind=kind_phys),dimension (im,1,1) :: & & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 + real (kind=kind_phys),dimension (im,1) :: orog, stdev real (kind=kind_phys),dimension (im,1) :: & & albbck_lnd, alb_lnd, chs_lnd, flhc_lnd, flqc_lnd, & & wet, wet_ice, smmax, cmc, drip, ec, edir, ett, & @@ -493,7 +496,7 @@ subroutine lsm_ruc_run & ! inputs & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & - & precipfr, snfallac_lnd, acsn, & + & precipfr, snfallac_lnd, acsn_lnd, & & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq ! ice real (kind=kind_phys),dimension (im,1) :: & @@ -502,7 +505,7 @@ subroutine lsm_ruc_run & ! inputs & solnet_ice, sfcems_ice, hfx_ice, & & sneqv_ice, snoalb1d_ice, snowh_ice, snoh_ice, tsnav_ice, & & snomlt_ice, sncovr_ice, ssoil_ice, soilt_ice, & - & z0_ice, znt_ice, snfallac_ice, & + & z0_ice, znt_ice, snfallac_ice, acsn_ice, & & qsfc_ice, qsg_ice, qvg_ice, qcg_ice, soilt1_ice @@ -541,8 +544,8 @@ subroutine lsm_ruc_run & ! inputs ipr = 10 !-- - testptlat = 74.12 !29.5 - testptlon = 164.0 !283.0 + testptlat = 68.6 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 298.6 !284.50 !286.75 !280.6 !164.0 !283.0 !-- debug_print=.false. @@ -632,7 +635,7 @@ subroutine lsm_ruc_run & ! inputs if(ivegsrc == 1) then llanduse = 'MODI-RUC' ! IGBP iswater = 17 - isice = 15 + isice = glacier else write(errmsg, '(a,i0)') 'Logic error in sfc_drv_ruc_run: iswater/isice not configured for ivegsrc=', ivegsrc errflg = 1 @@ -669,27 +672,32 @@ subroutine lsm_ruc_run & ! inputs wetness_old(i) = wetness(i) canopy_old(i) = canopy(i) !srflag_old(i) = srflag(i) - !acsnow_old(i) = acsnow(i) ! for land weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) tskin_lnd_old(i) = tskin_lnd(i) tsnow_lnd_old(i) = tsnow_lnd(i) - snowfallac_lnd_old(i) = snowfallac_lnd(i) sfcqv_lnd_old(i) = sfcqv_lnd(i) sfcqc_lnd_old(i) = sfcqc_lnd(i) z0rl_lnd_old(i) = z0rl_lnd(i) sncovr1_lnd_old(i) = sncovr1_lnd(i) + snowmt_lnd_old(i) = snowmt_lnd(i) + acsnow_lnd_old(i) = acsnow_lnd(i) + snowfallac_lnd_old(i) = snowfallac_lnd(i) + srunoff_old(i) = srunoff(i) + runoff_old(i) = runoff(i) ! for ice weasd_ice_old(i) = weasd_ice(i) snwdph_ice_old(i) = snwdph_ice(i) tskin_ice_old(i) = tskin_ice(i) tsnow_ice_old(i) = tsnow_ice(i) - snowfallac_ice_old(i) = snowfallac_ice(i) sfcqv_ice_old(i) = sfcqv_ice(i) sfcqc_ice_old(i) = sfcqc_ice(i) z0rl_ice_old(i) = z0rl_ice(i) sncovr1_ice_old(i) = sncovr1_ice(i) + snowmt_ice_old(i) = snowmt_ice(i) + acsnow_ice_old(i) = acsnow_ice(i) + snowfallac_ice_old(i) = snowfallac_ice(i) do k = 1, lsoil_ruc smois_old(i,k) = smois(i,k) @@ -723,6 +731,8 @@ subroutine lsm_ruc_run & ! inputs sbsno(i) = 0.0 !local i,j arrays + snoh_lnd(i,j) = 0.0 + snoh_ice(i,j) = 0.0 dew_lnd(i,j) = 0.0 dew_ice(i,j) = 0.0 soilm(i,j) = 0.0 @@ -733,22 +743,26 @@ subroutine lsm_ruc_run & ! inputs qfx_ice(i,j) = 0.0 lh_lnd(i,j) = 0.0 lh_ice(i,j) = 0.0 - acsn(i,j) = 0.0 + esnow_lnd(i,j) = 0.0 + esnow_ice(i,j) = 0.0 sfcexc(i,j) = 0.0 acceta(i,j) = 0.0 ssoil_lnd(i,j) = 0.0 ssoil_ice(i,j) = 0.0 - snomlt_lnd(i,j) = 0.0 - snomlt_ice(i,j) = 0.0 infiltr(i,j) = 0.0 + precipfr(i,j) = 0.0 + rhosnfr(i,j) = -1.e3 runoff1(i,j) = 0.0 runoff2(i,j) = 0.0 - acrunoff(i,j) = 0.0 - snfallac_lnd(i,j) = 0.0 - snfallac_ice(i,j) = 0.0 - rhosnfr(i,j) = 0.0 - precipfr(i,j) = 0.0 - + if(kdt == 1) then + acrunoff(i,j) = 0.0 + snfallac_lnd(i,j) = 0.0 + acsn_lnd(i,j) = 0.0 + snfallac_ice(i,j) = 0.0 + acsn_ice(i,j) = 0.0 + snomlt_lnd(i,j) = 0.0 + snomlt_ice(i,j) = 0.0 + endif endif enddo ! i=1,im enddo @@ -785,6 +799,13 @@ subroutine lsm_ruc_run & ! inputs frpcpn = .false. endif + do j = 1, 1 ! 1:1 + do i = 1, im ! i - horizontal loop + orog(i,j) = oro(i) !topography + stdev(i,j) = sigma(i) ! st. deviation (m) + enddo + enddo + do j = 1, 1 ! 1:1 do i = 1, im ! i - horizontal loop xice(i,j) = 0. @@ -808,9 +829,9 @@ subroutine lsm_ruc_run & ! inputs !> - 2. forcing data (f): !!\n \a sfcprs - pressure at height zf above ground (pascals) !!\n \a sfctmp - air temperature (\f$K\f$) at height zf above ground -!!\n \a q2 - pressure at height zf above ground (pascals) -!!\n \a qcatm - cloud water mising ration at height zf above ground (\f$kg !kg^{-1}\f$) -!!\n \a rho2 - air density at height zf above ground (pascals) +!!\n \a q2 - water vapor mix. ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a qcatm - cloud water mixing ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a rho2 - air density at height zf above ground ((\f$kg m^{-3}\f$)) sfcprs(i,1,j) = prsl1(i) sfctmp(i,1,j) = t1(i) @@ -825,7 +846,7 @@ subroutine lsm_ruc_run & ! inputs !!\n \a rainncv - time-step non-convective precip (\f$kg m^{-2} \f$) !!\n \a graupelncv - time-step graupel (\f$kg m^{-2} \f$) !!\n \a snowncv - time-step snow (\f$kg m^{-2} \f$) -!!\n \a precipfr - time-step precipitation in solod form (\f$kg m^{-2} \f$) +!!\n \a precipfr - time-step precipitation in solid form (\f$kg m^{-2} \f$) !!\n \a shdfac - areal fractional coverage of green vegetation (0.0-1.0) !!\n \a shdmin - minimum areal fractional coverage of green vegetation -> !shdmin1d !!\n \a shdmax - maximum areal fractional coverage of green vegetation -> !shdmax1d @@ -840,16 +861,16 @@ subroutine lsm_ruc_run & ! inputs !rainncv(i,j) = rhoh2o * max(rain(i)-rainc(i),0.0) ! total time-step explicit precip !graupelncv(i,j) = rhoh2o * graupel(i) !snowncv(i,j) = rhoh2o * snow(i) - prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! tprcp in [m] - convective plus explicit - raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip - rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip + prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! total time-step convective plus explicit [mm] + raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip [mm] + rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip [mm] graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + abs(xlon_d(i)-testptlon).lt.0.2)then + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i), & @@ -858,11 +879,12 @@ subroutine lsm_ruc_run & ! inputs 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'prsl1',prsl1(i),'t1',t1(i), & !'snow',snow(i), 'snowncv',snowncv(i,j), & - 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'srflag',srflag(i),'weasd mm ',weasd_lnd(i), & + 'tsnow_lnd',tsnow_lnd(i),'snwdph mm',snwdph_lnd(i), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif endif - 100 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) !-- ! ice precipitation is not used @@ -870,8 +892,6 @@ subroutine lsm_ruc_run & ! inputs ! ice not used ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - !acsn(i,j) = acsnow(i) - acsn(i,j) = 0.0 tbot(i,j) = tg3(i) @@ -966,7 +986,7 @@ subroutine lsm_ruc_run & ! inputs endif ! coszen > 0. snoalb1d_lnd(i,j) = snoalb(i) - albbck_lnd(i,j) = albbcksol(i) !sfalb_lnd_bck(i) + albbck_lnd(i,j) = min(0.9,albbcksol(i)) !sfalb_lnd_bck(i) !-- spp_lsm @@ -992,14 +1012,14 @@ subroutine lsm_ruc_run & ! inputs solnet_lnd(i,j) = dswsfc(i)*(1.-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 cmc(i,j) = canopy(i) ! [mm] - soilt_lnd(i,j) = tsurf_lnd(i) ! clu_q2m_iter + soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow - if (tsnow_lnd(i) > 0. .and. tsnow_lnd(i) < 273.15) then + if (tsnow_lnd(i) > 200. .and. tsnow_lnd(i) < 273.15) then soilt1_lnd(i,j) = tsnow_lnd(i) else soilt1_lnd(i,j) = tsurf_lnd(i) endif - tsnav_lnd(i,j) = 0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15 + tsnav_lnd(i,j) = min(0.,0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15) do k = 1, lsoil_ruc smsoil (i,k,j) = smois(i,k) slsoil (i,k,j) = sh2o(i,k) @@ -1015,27 +1035,79 @@ subroutine lsm_ruc_run & ! inputs endif chs_lnd (i,j) = ch_lnd(i) * wind(i) ! compute conductance - flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (1.+0.84*q2(i,1,j)) flqc_lnd(i,j) = chs_lnd(i,j) * rho(i) * wet(i,j) + ! for output cmm_lnd(i) = cm_lnd(i) * wind(i) chh_lnd(i) = chs_lnd(i,j) * rho(i) ! - snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - sneqv_lnd(i,j) = weasd_lnd(i) ! [mm] - snfallac_lnd(i,j) = snowfallac_lnd(i) - !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0 .and. snowh_lnd(i,j) == 0.0) then - snowh_lnd(i,j) = 0.003 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + sneqv_lnd(i,j) = weasd_lnd(i) + snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m + + if(kdt > 1) then + !-- run-total accumulation + snfallac_lnd(i,j) = snowfallac_lnd(i) + acsn_lnd(i,j) = acsnow_lnd(i) + snomlt_lnd(i,j) = snowmt_lnd(i) endif - if (snowh_lnd(i,j) /= 0.0 .and. sneqv_lnd(i,j) == 0.0) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) ! snow density ~300 kg m-3 - endif - - if (sneqv_lnd(i,j) > 0. .and. snowh_lnd(i,j) > 0.) then - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 950.) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) + !> -- sanity checks on sneqv and snowh + if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(sneqv_lnd(i,j) < 1.e-7.or.soilt_lnd(i,j)>273.15d0) then + sneqv_lnd(i,j) = 0.d0 + snowh_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 300.d0 * snowh_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (snowh_lnd(i,j) /= 0.0d0 .and. sneqv_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(snowh_lnd(i,j) < 3.d-10.or.soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.003d0 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (sneqv_lnd(i,j) > 0.d0 .and. snowh_lnd(i,j) > 0.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.2.5 .and. & + abs(xlon_d(i)-testptlon).lt.2.5)then + print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.002d0 * sneqv_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 58.d0 * snowh_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif endif endif @@ -1113,8 +1185,35 @@ subroutine lsm_ruc_run & ! inputs endif endif + !if (debug_print) then + !-- diagnostics for a land test point with known lat/lon + if (kdt < 10) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + !if(weasd_lnd(i) > 0.) & + print 100,'(ruc_lsm_drv before RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & + 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& + !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& + 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & + 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & + 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & + 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j),& + 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & + 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & + 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & + 'keepfrsoil',keepfrsoil(i,1,j), & + 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) + endif + endif ! debug_print + !-- + !> - Call RUC LSM lsmruc() for land. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & @@ -1122,6 +1221,7 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_lnd(i,j), sfcems_lnd(i,j), chklowq(i,j), & @@ -1142,50 +1242,54 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smsoil(i,:,j), slsoil(i,:,j), soilm(i,j), smmax(i,j), & & stsoil(i,:,j), soilt_lnd(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_lnd(i,j), snoh_lnd(i,j), & & hfx_lnd(i,j), qfx_lnd(i,j), lh_lnd(i,j), & & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_lnd(i,j), & - & snfallac_lnd(i,j), acsn(i,j), snomlt_lnd(i,j), & + & snfallac_lnd(i,j), acsn_lnd(i,j), snomlt_lnd(i,j), & & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) - if(debug_print) then - write (0,*)'after LSMRUC for land' - write (0,*)'after sneqv(i,j) =',i,j,sneqv_lnd(i,j) - write (0,*)'after snowh(i,j) =',i,j,snowh_lnd(i,j) - write (0,*)'after sncovr(i,j) =',i,j,sncovr_lnd(i,j) - write (0,*)'after vtype(i,j) =',i,j,vtype_lnd(i,j) - write (0,*)'after stype(i,j) =',i,j,stype_lnd(i,j) - write (0,*)'after wet(i,j) =',i,j,wet(i,j) - write (0,*)'after cmc(i,j) =',i,j,cmc(i,j) - write (0,*)'after qsfc(i,j) =',i,j,qsfc_lnd(i,j) - write (0,*)'after qvg(i,j) =',i,j,qvg_lnd(i,j) - write (0,*)'after qsg(i,j) =',i,j,qsg_lnd(i,j) - write (0,*)'after qcg(i,j) =',i,j,qcg_lnd(i,j) - write (0,*)'after dew(i,j) =',i,j,dew_lnd(i,j) - write (0,*)'after soilt(i,j) =',i,j,soilt_lnd(i,j) - write (0,*)'after tskin(i) =',i,j,tskin_lnd(i) - write (0,*)'after soilt1(i,j) =',i,j,soilt1_lnd(i,j) - write (0,*)'after tsnav(i,j) =',i,j,tsnav_lnd(i,j) - write (0,*)'after smsoil(i,:,j)=',i,j,smsoil(i,:,j) - write (0,*)'after slsoil(i,:,j)=',i,j,slsoil(i,:,j) - write (0,*)'after stsoil(i,:,j)=',i,j,stsoil(i,:,j) - write (0,*)'after smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) - write (0,*)'after keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'after soilm(i,j) =',i,j,soilm(i,j) - write (0,*)'after smmax(i,j) =',i,j,smmax(i,j) - write (0,*)'after hfx(i,j) =',i,j,hfx_lnd(i,j) - write (0,*)'after qfx(i,j) =',i,j,qfx_lnd(i,j) - write (0,*)'after lh(i,j) =',i,j,lh_lnd(i,j) - write (0,*)'after infiltr(i,j) =',i,j,infiltr(i,j) - write (0,*)'after runoff1(i,j) =',i,j,runoff1(i,j) - write (0,*)'after runoff2(i,j) =',i,j,runoff2(i,j) - write (0,*)'after ssoil(i,j) =',i,j,ssoil_lnd(i,j) - write (0,*)'after snfallac(i,j) =',i,j,snfallac_lnd(i,j) - write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'after snomlt(i,j) =',i,j,snomlt_lnd(i,j) - endif + if(debug_print) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print 100,'(ruc_lsm_drv after RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'sneqv(i,j) =',sneqv_lnd(i,j), & + 'snowh(i,j) =',snowh_lnd(i,j), & + 'sncovr(i,j) =',sncovr_lnd(i,j), & + 'vtype(i,j) =',vtype_lnd(i,j), & + 'stype(i,j) =',stype_lnd(i,j), & + 'wet(i,j) =',wet(i,j), & + 'cmc(i,j) =',cmc(i,j), & + 'qsfc(i,j) =',qsfc_lnd(i,j), & + 'qvg(i,j) =',qvg_lnd(i,j), & + 'qsg(i,j) =',qsg_lnd(i,j), & + 'qcg(i,j) =',qcg_lnd(i,j), & + 'dew(i,j) =',dew_lnd(i,j), & + 'soilt(i,j) =',soilt_lnd(i,j), & + 'tskin(i) =',tskin_lnd(i), & + 'soilt1(i,j) =',soilt1_lnd(i,j), & + 'tsnav(i,j) =',tsnav_lnd(i,j), & + 'smsoil(i,:,j)=',smsoil(i,:,j), & + 'slsoil(i,:,j)=',slsoil(i,:,j), & + 'stsoil(i,:,j)=',stsoil(i,:,j), & + 'smfrsoil(i,:,j)=',smfrsoil(i,:,j), & + 'keepfrsoil(i,:,j)=',keepfrsoil(i,:,j), & + 'soilm(i,j) =',soilm(i,j), & + 'smmax(i,j) =',smmax(i,j), & + 'hfx(i,j) =',hfx_lnd(i,j), & + 'lh(i,j) =',lh_lnd(i,j), & + 'infiltr(i,j) =',infiltr(i,j), & + 'runoff1(i,j) =',runoff1(i,j), & + 'runoff2(i,j) =',runoff2(i,j), & + 'ssoil(i,j) =',ssoil_lnd(i,j), & + 'snfallac(i,j) =',snfallac_lnd(i,j), & + 'acsn_lnd(i,j) =',acsn_lnd(i,j), & + 'snomlt(i,j) =',snomlt_lnd(i,j) + endif + endif !> - RUC LSM: prepare variables for return to parent model and unit conversion. @@ -1195,23 +1299,22 @@ subroutine lsm_ruc_run & ! inputs !!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) !!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface !!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) -!!\n \a lh - actual latent heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a hfx - sensible heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) -!!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface -!!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) +!!\n \a snoh - phase-change heat flux from snowmelt (\f$W m^{-2}\f$) ! -! --- ... do not return the following output fields to parent model -! ec - canopy water evaporation (m s-1) -! edir - direct soil evaporation (m s-1) +! --- ... units [m/s] = [g m-2 s-1] +! evcw (W m-2) - canopy water evaporation flux +! evbs (W m-2) - direct soil evaporation flux +! trans (W m-2) - total plant transpiration +! edir, ec, ett - direct evaporation, evaporation of +! canopy water and transpiration (kg m-2 s-1) ! et(nsoil)-plant transpiration from a particular root layer (m s-1) -! ett - total plant transpiration (m s-1) -! esnow - sublimation from (or deposition to if <0) snowpack (m s-1) +! esnow - sublimation from (or deposition to if <0) snowpack (kg m-2 s-1) +! sbsno - sublimation from (or deposition to if <0) snowpack (W m-2) +! hfx - upward heat flux at the surface (W/m^2) +! qfx - upward moisture flux at the surface (kg kg-1 kg m-2 s-1) ! drip - through-fall of precip and/or dew in excess of canopy ! water-holding capacity (m) -! snomlt - snow melt (m) (water equivalent) +! snomlt - snow melt (kg m-2) (water equivalent) ! xlai - leaf area index (dimensionless) ! soilw - available soil moisture in root zone (unitless fraction ! between smcwlt and smcmax) @@ -1219,40 +1322,39 @@ subroutine lsm_ruc_run & ! inputs ! nroot - number of root layers, a function of veg type, determined ! in subroutine redprm. - - !evbs(i) = edir(i,j) - !evcw(i) = ec(i,j) - !trans(i) = ett(i,j) - !sbsno(i) = esnow(i,j) - !snohf(i) = snoh(i,j) + evbs(i) = edir(i,j) * rhoh2o * con_hvap + evcw(i) = ec(i,j) * rhoh2o * con_hvap + trans(i) = ett(i,j) * rhoh2o * con_hvap + sbsno(i) = esnow_lnd(i,j) * con_hfus + snohf(i) = snoh_lnd(i,j) ! Interstitial - evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kinematic - hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! kinematic + evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kg kg-1 m s-1 kinematic + hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! K m s-1 kinematic gflux_lnd(i) = ssoil_lnd(i,j) qsurf_lnd(i) = qsfc_lnd(i,j) tsurf_lnd(i) = soilt_lnd(i,j) tsnow_lnd(i) = soilt1_lnd(i,j) stm(i) = soilm(i,j) * 1.e-3 ! convert to [m] - runof (i) = runoff1(i,j) - drain (i) = runoff2(i,j) + runof (i) = runoff1(i,j) * rhoh2o ! surface kg m-2 s-1 + drain (i) = runoff2(i,j) * rhoh2o ! kg m-2 s-1 wetness(i) = wet(i,j) - - ! tsnow(i) = soilt1(i,j) sfcqv_lnd(i) = qvg_lnd(i,j) sfcqc_lnd(i) = qcg_lnd(i,j) - ! --- ... units [m/s] = [g m-2 s-1] - rhosnf(i) = rhosnfr(i,j) - !acsnow(i) = acsn(i,j) ! kg m-2 + + rhosnf(i) = rhosnfr(i,j) ! kg m-3 + acsnow_lnd(i) = acsn_lnd(i,j) ! accum kg m-2 + snowmt_lnd(i) = snomlt_lnd(i,j) ! accum kg m-2 ! --- ... accumulated total runoff and surface runoff - runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt * 0.001 ! kg m-2 - srunoff(i) = srunoff(i) + runof(i) * delt * 0.001 ! kg m-2 + runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt ! accum total kg m-2 + !srunoff(i) = srunoff(i) + runof(i) * delt ! accum surface kg m-2 + srunoff(i) = acrunoff(i,j) ! accum surface kg m-2 ! --- ... accumulated frozen precipitation (accumulation in lsmruc) - snowfallac_lnd(i) = snfallac_lnd(i,j) ! kg m-2 + snowfallac_lnd(i) = snfallac_lnd(i,j) ! accum kg m-2 ! --- ... unit conversion (from m to mm) snwdph_lnd(i) = snowh_lnd(i,j) * 1000.0 @@ -1271,7 +1373,7 @@ subroutine lsm_ruc_run & ! inputs !-- fill in albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_lnd(i) = sfalb_lnd(i) albdnir_lnd(i) = sfalb_lnd(i) - albinir_lnd(i) = sfalb_lnd(i) + albivis_lnd(i) = sfalb_lnd(i) albinir_lnd(i) = sfalb_lnd(i) do k = 1, lsoil_ruc @@ -1292,23 +1394,26 @@ subroutine lsm_ruc_run & ! inputs !-- ice point if (debug_print) then - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & - print 101,'(ruc_lsm_drv ice) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i),'flag_ice',flag_ice(i),& + if (abs(xlat_d(i)-testptlat).lt.0.1 .and. & + abs(xlon_d(i)-testptlon).lt.0.1)then + !if(weasd_ice(i) > 0.) & + print 101,'(ruc_lsm_drv_ice) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & !'rainc',rainc(i),'rainnc',rainnc(i), & 'sfcqv_ice',sfcqv_ice(i),& !'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_ice',sncovr1_ice(i),'sfalb_ice',sfalb_ice(i),& 'sfcqc_ice',sfcqc_ice(i),'tsnow_ice',tsnow_ice(i), & - 'prsl1',prsl1(i),'t1',t1(i), & - !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'prsl1',prsl1(i),'t1',t1(i),'snwdph_ice ',snwdph_ice(i), & 'srflag',srflag(i),'weasd_ice',weasd_ice(i), & 'tsurf_ice',tsurf_ice(i),'tslb(i,1)',tslb(i,1) endif endif - 101 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 101 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) + + edir (i,j) = 0.0 + ec (i,j) = 0.0 + ett (i,j) = 0.0 sncovr_ice(i,j) = sncovr1_ice(i) !-- alb_ice* is computed in setalb called from rrtmg_sw_pre. @@ -1327,13 +1432,13 @@ subroutine lsm_ruc_run & ! inputs sfcems_ice(i,j) = semis_ice(i) endif cmc(i,j) = canopy(i) ! [mm] - soilt_ice(i,j) = tsurf_ice(i) ! clu_q2m_iter - if (tsnow_ice(i) > 0. .and. tsnow_ice(i) < 273.15) then + soilt_ice(i,j) = tsurf_ice(i) + if (tsnow_ice(i) > 150. .and. tsnow_ice(i) < 273.15) then soilt1_ice(i,j) = tsnow_ice(i) else soilt1_ice(i,j) = tsurf_ice(i) endif - tsnav_ice(i,j) = 0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15 + tsnav_ice(i,j) = min(0.,0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15) do k = 1, lsoil_ruc stsice (i,k,j) = tsice(i,k) smice (i,k,j) = 1. @@ -1345,8 +1450,9 @@ subroutine lsm_ruc_run & ! inputs wet_ice(i,j) = 1. chs_ice (i,j) = ch_ice(i) * wind(i) ! compute conductance - flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (1. + 0.84*q2(i,1,j)) flqc_ice(i,j) = chs_ice(i,j) * rho(i) * wet_ice(i,j) + ! for output cmm_ice(i) = cm_ice (i) * wind(i) chh_ice(i) = chs_ice(i,j) * rho(i) @@ -1354,7 +1460,11 @@ subroutine lsm_ruc_run & ! inputs snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m sneqv_ice(i,j) = weasd_ice(i) ! [mm] - snfallac_ice(i,j) = snowfallac_ice(i) + if(kdt > 1) then + snfallac_ice(i,j) = snowfallac_ice(i) + acsn_ice(i,j) = acsnow_ice(i) + snomlt_ice(i,j) = snowmt_ice(i) + endif !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then @@ -1374,6 +1484,9 @@ subroutine lsm_ruc_run & ! inputs z0_ice(i,j) = z0rl_ice(i)/100. znt_ice(i,j) = z0rl_ice(i)/100. + runoff1(i,j) = 0. + runoff2(i,j) = 0. + ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check ! results in subnormal numbers. @@ -1388,7 +1501,7 @@ subroutine lsm_ruc_run & ! inputs endif !> - Call RUC LSM lsmruc() for ice. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & @@ -1396,6 +1509,7 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_ice(i,j), sfcems_ice(i,j), chklowq(i,j), & @@ -1416,10 +1530,11 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smice(i,:,j), slice(i,:,j), soilm(i,j), smmax(i,j), & & stsice(i,:,j), soilt_ice(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_ice(i,j), snoh_ice(i,j), & & hfx_ice(i,j), qfx_ice(i,j), lh_ice(i,j), & & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_ice(i,j), & - & snfallac_ice(i,j), acsn(i,j), snomlt_ice(i,j), & + & snfallac_ice(i,j), acsn_ice(i,j), snomlt_ice(i,j), & & smfrice(i,:,j),keepfrice(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & @@ -1438,19 +1553,23 @@ subroutine lsm_ruc_run & ! inputs sfcqv_ice(i) = qvg_ice(i,j) sfcqc_ice(i) = qcg_ice(i,j) + rhosnf(i) = rhosnfr(i,j) ! kg m-3 snowfallac_ice(i) = snfallac_ice(i,j) ! kg m-2 + acsnow_ice(i) = acsn_ice(i,j) ! kg m-2 + snowmt_ice(i) = snomlt_ice(i,j) ! kg m-2 ! --- ... unit conversion (from m to mm) - snwdph_ice(i) = snowh_ice(i,j) * 1000.0 - weasd_ice(i) = sneqv_ice(i,j) ! mm + snwdph_ice(i) = snowh_ice(i,j) * rhoh2o + weasd_ice(i) = sneqv_ice(i,j) ! kg m-2 sncovr1_ice(i) = sncovr_ice(i,j) - z0rl_ice(i) = znt_ice(i,j)*100. + z0rl_ice(i) = znt_ice(i,j)*100. ! cm !-- semis_ice is with snow effect semis_ice(i) = sfcems_ice(i,j) !-- sfalb_ice is with snow effect sfalb_ice(i) = alb_ice(i,j) + !-- albdvis_ice,albdnir_ice,albivis_ice,albinir_ice albdvis_ice(i) = sfalb_ice(i) albdnir_ice(i) = sfalb_ice(i) - albinir_ice(i) = sfalb_ice(i) + albivis_ice(i) = sfalb_ice(i) albinir_ice(i) = sfalb_ice(i) @@ -1492,22 +1611,27 @@ subroutine lsm_ruc_run & ! inputs !srflag(i) = srflag_old(i) tsnow_lnd(i) = tsnow_lnd_old(i) snowfallac_lnd(i) = snowfallac_lnd_old(i) - !acsnow(i) = acsnow_old(i) + acsnow_lnd(i) = acsnow_lnd_old(i) sfcqv_lnd(i) = sfcqv_lnd_old(i) sfcqc_lnd(i) = sfcqc_lnd_old(i) wetness(i) = wetness_old(i) z0rl_lnd(i) = z0rl_lnd_old(i) sncovr1_lnd(i) = sncovr1_lnd_old(i) + snowmt_lnd(i) = snowmt_lnd_old(i) !ice weasd_ice(i) = weasd_ice_old(i) snwdph_ice(i) = snwdph_ice_old(i) tskin_ice(i) = tskin_ice_old(i) tsnow_ice(i) = tsnow_ice_old(i) snowfallac_ice(i) = snowfallac_ice_old(i) + acsnow_ice(i) = acsnow_ice_old(i) sfcqv_ice(i) = sfcqv_ice_old(i) sfcqc_ice(i) = sfcqc_ice_old(i) z0rl_ice(i) = z0rl_ice_old(i) sncovr1_ice(i) = sncovr1_ice_old(i) + snowmt_ice(i) = snowmt_ice_old(i) + srunoff(i) = srunoff_old(i) + runoff(i) = runoff_old(i) do k = 1, lsoil_ruc smois(i,k) = smois_old(i,k) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 587fda681e..e8290de548 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -671,6 +671,22 @@ type = real kind = kind_phys intent = in +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sigma] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [zs] standard_name = depth_of_soil_layers long_name = depth of soil levels for land surface model @@ -1000,6 +1016,14 @@ type = real kind = kind_phys intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [con_fvirt] standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) @@ -1329,13 +1353,37 @@ kind = kind_phys intent = inout [snowfallac_lnd] - standard_name = surface_snow_amount_over_land - long_name = run-total snow accumulation on the ground over land + standard_name = surface_snow_amount_vardens_over_land + long_name = run-total snow accumulation on the ground with variable snow density over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_lnd] + standard_name = surface_snow_lwe_thickness_amount_over_land + long_name = run-total snowfall water equivalent over land units = kg m-2 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout +[snowmt_lnd] + standard_name = surface_snow_melt_over_land + long_name = snow melt during timestep over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [albdvis_lnd] standard_name = surface_albedo_direct_visible_over_land long_name = direct surface albedo visible band over land @@ -1465,8 +1513,24 @@ kind = kind_phys intent = in [snowfallac_ice] - standard_name = surface_snow_amount_over_ice - long_name = run-total snow accumulation on the ground over ice + standard_name = surface_snow_amount_vardens_over_ice + long_name = run-total snow accumulation on the ground with variable snow density over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_ice] + standard_name = surface_snow_lwe_thickness_amount_over_ice + long_name = run-total snowfall water equivalent over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowmt_ice] + standard_name = surface_snow_melt_over_ice + long_name = snow melt during timestep over ice units = kg m-2 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/mersenne_twister.f b/physics/mersenne_twister.f index 58bf434878..8cc6bd5e5e 100644 --- a/physics/mersenne_twister.f +++ b/physics/mersenne_twister.f @@ -160,7 +160,6 @@ ! !$$$ module mersenne_twister - use machine, only: kind_dbl_prec private ! Public declarations public random_stat @@ -189,7 +188,7 @@ module mersenne_twister integer:: mti=n+1 integer:: mt(0:n-1) integer:: iset - real(kind_dbl_prec):: gset + real:: gset end type ! Saved data type(random_stat),save:: sstat @@ -301,8 +300,8 @@ subroutine random_setseed_t(inseed,stat) !> This function generates random numbers in functional mode. function random_number_f() result(harvest) implicit none - real(kind_dbl_prec):: harvest - real(kind_dbl_prec) :: h(1) + real:: harvest + real h(1) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_number_t(h,sstat) harvest=h(1) @@ -311,7 +310,7 @@ function random_number_f() result(harvest) !> This subroutine generates random numbers in interactive mode. subroutine random_number_i(harvest,inseed) implicit none - real(kind_dbl_prec),intent(out):: harvest(:) + real,intent(out):: harvest(:) integer,intent(in):: inseed type(random_stat) stat call random_setseed_t(inseed,stat) @@ -321,7 +320,7 @@ subroutine random_number_i(harvest,inseed) !> This subroutine generates random numbers in saved mode; overloads Fortran 90 standard. subroutine random_number_s(harvest) implicit none - real(kind_dbl_prec),intent(out):: harvest(:) + real,intent(out):: harvest(:) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_number_t(harvest,sstat) end subroutine @@ -329,7 +328,7 @@ subroutine random_number_s(harvest) !> This subroutine generates random numbers in thread-safe mode. subroutine random_number_t(harvest,stat) implicit none - real(kind_dbl_prec),intent(out):: harvest(:) + real,intent(out):: harvest(:) type(random_stat),intent(inout):: stat integer j,kk,y integer tshftu,tshfts,tshftt,tshftl @@ -360,12 +359,9 @@ subroutine random_number_t(harvest,stat) y=ieor(y,iand(tshftt(y),tmaskc)) y=ieor(y,tshftl(y)) if(y.lt.0) then - harvest(j)=(real(y,kind=kind_dbl_prec)+ & - & 2.0_kind_dbl_prec**32)/ & - & (2.0_kind_dbl_prec**32-1.0_kind_dbl_prec) + harvest(j)=(real(y)+2.0**32)/(2.0**32-1.0) else - harvest(j)=real(y)/(2.0_kind_dbl_prec**32- & - & 1.0_kind_dbl_prec) + harvest(j)=real(y)/(2.0**32-1.0) endif stat%mti=stat%mti+1 enddo @@ -374,8 +370,8 @@ subroutine random_number_t(harvest,stat) !> This subrouitne generates Gaussian random numbers in functional mode. function random_gauss_f() result(harvest) implicit none - real(kind_dbl_prec):: harvest - real(kind_dbl_prec) :: h(1) + real:: harvest + real h(1) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_gauss_t(h,sstat) harvest=h(1) @@ -384,7 +380,7 @@ function random_gauss_f() result(harvest) !> This subrouitne generates Gaussian random numbers in interactive mode. subroutine random_gauss_i(harvest,inseed) implicit none - real(kind_dbl_prec),intent(out):: harvest(:) + real,intent(out):: harvest(:) integer,intent(in):: inseed type(random_stat) stat call random_setseed_t(inseed,stat) @@ -394,7 +390,7 @@ subroutine random_gauss_i(harvest,inseed) !> This subroutine generates Gaussian random numbers in saved mode. subroutine random_gauss_s(harvest) implicit none - real(kind_dbl_prec),intent(out):: harvest(:) + real,intent(out):: harvest(:) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_gauss_t(harvest,sstat) end subroutine @@ -402,10 +398,10 @@ subroutine random_gauss_s(harvest) !> This subroutine generates Gaussian random numbers in thread-safe mode. subroutine random_gauss_t(harvest,stat) implicit none - real(kind_dbl_prec),intent(out):: harvest(:) + real,intent(out):: harvest(:) type(random_stat),intent(inout):: stat integer mx,my,mz,j - real(kind_dbl_prec) :: r2(2),r,g1,g2 + real r2(2),r,g1,g2 mz=size(harvest) if(mz.le.0) return mx=0 @@ -440,14 +436,14 @@ subroutine random_gauss_t(harvest,stat) contains !> This subroutine contains numerical Recipes algorithm to generate Gaussian random numbers. subroutine rgauss(r1,r2,r,g1,g2) - real(kind_dbl_prec),intent(in):: r1,r2 - real(kind_dbl_prec),intent(out):: r,g1,g2 - real(kind_dbl_prec) :: v1,v2,fac - v1=2._kind_dbl_prec*r1-1._kind_dbl_prec - v2=2._kind_dbl_prec*r2-1._kind_dbl_prec + real,intent(in):: r1,r2 + real,intent(out):: r,g1,g2 + real v1,v2,fac + v1=2.*r1-1. + v2=2.*r2-1. r=v1**2+v2**2 if(r.lt.1.) then - fac=sqrt(-2._kind_dbl_prec*log(r)/r) + fac=sqrt(-2.*log(r)/r) g1=v1*fac g2=v2*fac endif @@ -493,7 +489,7 @@ subroutine random_index_t(imax,iharvest,stat) type(random_stat),intent(inout):: stat integer,parameter:: mh=n integer i1,i2,mz - real(kind_dbl_prec) :: h(mh) + real h(mh) mz=size(iharvest) do i1=1,mz,mh i2=min((i1-1)+mh,mz) diff --git a/physics/mfpbl.f b/physics/mfpbl.f index dac5487113..2df84945b2 100644 --- a/physics/mfpbl.f +++ b/physics/mfpbl.f @@ -1,7 +1,6 @@ !> \file mfpbl.f !! This file contains the subroutine that calculates the updraft properties and mass flux for use in the Hybrid EDMF PBL scheme. - module mfpbl_mod - contains + !> \ingroup HEDMF !! \brief This subroutine is used for calculating the mass flux and updraft properties. !! @@ -397,4 +396,3 @@ subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg, & return end !> @} - end module mfpbl_mod diff --git a/physics/mfpblt.f b/physics/mfpblt.f index 67e554b929..bd0baf558e 100644 --- a/physics/mfpblt.f +++ b/physics/mfpblt.f @@ -2,8 +2,7 @@ !! This file contains the subroutine that calculates mass flux and !! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme. - module mfpblt_mod - contains + !>\ingroup satmedmf !! This subroutine computes mass flux and updraft parcel properties for !! thermals driven by surface heating. @@ -453,4 +452,3 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & return end !> @} - end module mfpblt_mod diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index fb775e2e12..61d5f3e586 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -478,4 +478,3 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, return end !> @} - end module mfpbltq_mod diff --git a/physics/mfscu.f b/physics/mfscu.f index e0c1841393..9128c7c10b 100644 --- a/physics/mfscu.f +++ b/physics/mfscu.f @@ -1,8 +1,7 @@ !>\file mfscu.f !! This file contains the mass flux and downdraft parcel preperties !! parameterization for stratocumulus-top-driven turbulence. - module mfscu_mod - contains + !>\ingroup satmedmf !! This subroutine computes mass flux and downdraft parcel properties !! for stratocumulus-top-driven turbulence. @@ -555,4 +554,3 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & return end !> @} - end module mfscu_mod diff --git a/physics/mfscuq.f b/physics/mfscuq.f index cafa61b55d..aa50cee4c8 100644 --- a/physics/mfscuq.f +++ b/physics/mfscuq.f @@ -559,4 +559,3 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, return end !> @} - end module mfscuq_mod diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index ffb4b5696c..b5dfccea07 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -248,7 +248,7 @@ MODULE module_bl_mynn xlvcp , tv0 , tv1 , tref , & zero , half , one , two , & onethird , twothirds , tkmin , t0c , & - tice + tice , kind_phys IMPLICIT NONE @@ -301,6 +301,7 @@ MODULE module_bl_mynn ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 @@ -383,32 +384,30 @@ MODULE module_bl_mynn SUBROUTINE mynn_bl_driver( & &initflag,restart,cycling, & &delt,dz,dx,znt, & - &u,v,w,th,sqv3D,sqc3D,sqi3D, & + &u,v,w,th,sqv3d,sqc3d,sqi3d, & &qnc,qni, & &qnwfa,qnifa,ozone, & - &p,exner,rho,T3D, & + &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, & + &qke,qke_adv, & &sh3d,sm3d, & - &nchem,kdvel,ndvel, & !Smoke/Chem variables - &chem3d, vdep, & - &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,fire_turb,rrfs_smoke, & ! end smoke/chem variables - - &Tsq,Qsq,Cov, & - &RUBLTEN,RVBLTEN,RTHBLTEN, & - &RQVBLTEN,RQCBLTEN,RQIBLTEN, & - &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN, & - &DOZONE, & + &chem3d,vdep,smoke_dbg, & + &frp,emis_ant_no, & ! JLS/RAR to adjust exchange coeffs + &mix_chem,enh_mix,rrfs_sd, & ! end smoke/chem variables + &tsq,qsq,cov, & + &rublten,rvblten,rthblten, & + &rqvblten,rqcblten,rqiblten, & + &rqncblten,rqniblten, & + &rqnwfablten,rqnifablten, & + &dozone, & &exch_h,exch_m, & - &Pblh,kpbl, & + &pblh,kpbl, & &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & + &dqke,qwt,qshear,qbuoy,qdiss, & &qc_bl,qi_bl,cldfra_bl, & &bl_mynn_tkeadvect, & &bl_mynn_tkebudget, & @@ -428,7 +427,7 @@ SUBROUTINE mynn_bl_driver( & &det_thl3D,det_sqv3D, & &nupdraft,maxMF,ktop_plume, & &spp_pbl,pattern_spp_pbl, & - &RTHRATEN, & + &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & &FLAG_OZONE & @@ -453,12 +452,12 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: bl_mynn_cloudmix INTEGER, INTENT(in) :: bl_mynn_mixqt INTEGER, INTENT(in) :: icloud_bl - REAL, INTENT(in) :: closure + REAL(kind=kind_phys), INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE - LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke + LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & @@ -480,71 +479,68 @@ SUBROUTINE mynn_bl_driver( & ! 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(:), INTENT(in) :: dx - REAL, DIMENSION(:,:), INTENT(in) :: dz, & + REAL(kind=kind_phys), INTENT(in) :: delt + REAL(kind=kind_phys), DIMENSION(:), INTENT(in) :: dx + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(:,:), INTENT(in):: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(:,:), INTENT(in):: ozone - REAL, DIMENSION(:), INTENT(in) :: xland,ust, & - &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in):: ozone + REAL(kind=kind_phys), DIMENSION(:), INTENT(in):: ust, & + &ch,qsfc,ps,wspd + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + &rublten,rvblten,rthblten,rqvblten,rqcblten, & + &rqiblten,rqniblten,rqncblten, & + &rqnwfablten,rqnifablten + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten - REAL, DIMENSION(:,:), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(:,:), INTENT(inout) :: DOZONE - - REAL, DIMENSION(:,:), INTENT(in) :: RTHRATEN - - REAL, DIMENSION(:,:), INTENT(out) :: & - &exch_h,exch_m + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m + REAL, DIMENSION(:), INTENT(in) :: xland,ts,znt,hfx,qfx, & + &uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(:,:), INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + REAL(kind=kind_phys), 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(:), INTENT(inout) :: Pblh,rmol + REAL(kind=kind_phys), DIMENSION(:), INTENT(inout) :: Pblh + REAL, DIMENSION(:), INTENT(inout) :: rmol REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(:), INTENT(OUT) :: & - &maxmf + REAL(kind=kind_phys), DIMENSION(:), INTENT(out) :: maxmf - REAL, DIMENSION(:,:), INTENT(inout) :: & - &el_pbl + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl - REAL, DIMENSION(:,:), INTENT(out) :: & + REAL(kind=kind_phys), 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(:,:), intent(out) :: Sh3D,Sm3D + REAL(kind=kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& + REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D, & qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old ! smoke/chemical arrays 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(:, :, :), INTENT(INOUT) :: chem3d - REAL, DIMENSION(:, :), INTENT(IN) :: vdep - REAL, DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + REAL(kind=kind_phys), DIMENSION(:, :, :), INTENT(INOUT) :: chem3d + REAL(kind=kind_phys), DIMENSION(:, :), INTENT(IN) :: vdep + REAL(kind=kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local REAL, DIMENSION(kts:kte ,nchem) :: chem1 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 @@ -553,68 +549,82 @@ SUBROUTINE mynn_bl_driver( & !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, & + INTEGER :: i,j,k,kproblem + 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, vdfg + 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, & + 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, & + 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) :: 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 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 + & th_sfc,ztop_plume,sqc9,sqi9,wsp !top-down diffusion REAL, DIMENSION(ITS:ITE) :: maxKHtopdown REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD - LOGICAL :: INITIALIZE_QKE + LOGICAL :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( :, :), INTENT(IN) ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) ::rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + REAL(kind=kind_phys), DIMENSION( :, :), INTENT(IN) :: pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col ! Substepping TKE INTEGER :: nsub - real :: delt2 - - 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 + real(kind=kind_phys) :: delt2 + + + if (debug_code) then !check incoming values + do i=its,ite + problem = .false. + do k=kts,kte + wsp = sqrt(u(i,k)**2 + v(i,k)**2) + if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or. & + wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. & + sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then + kproblem = k + problem = .true. + print*,"Incoming problem at: i=",i," k=1" + print*," QFX=",qfx(i)," HFX=",hfx(i) + print*," wsp=",wsp," T=",t3d(i,k) + print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k) + print*," u*=",ust(i)," wspd=",wspd(i) + print*," xland=",xland(i)," ts=",ts(i) + print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i) + print*," znt=",znt(i)," dx=",dx(i) + endif + enddo + if (problem) then + print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte)) + endif + enddo + endif !*** Begin debugging IMD=(IMS+IME)/2 @@ -1052,9 +1062,9 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF ( rrfs_smoke .and. mix_chem ) then + IF ( mix_chem ) then do ic = 1,ndvel - vd1(ic) = vdep(i,ic) !is this correct???? + vd1(ic) = vdep(i,ic) ! dry deposition velocity chem1(kts,ic) = chem3d(i,kts,ic) s_awchem1(kts,ic)=0. enddo @@ -1066,7 +1076,7 @@ SUBROUTINE mynn_bl_driver( & enddo ELSE do ic = 1,ndvel - vd1(ic) = 0. !is this correct??? (ite) or (ndvel) + vd1(ic) = 0. ! dry deposition velocity chem1(kts,ic) = 0. s_awchem1(kts,ic)=0. enddo @@ -1178,7 +1188,8 @@ SUBROUTINE mynn_bl_driver( & !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. CALL mym_condensation ( kts,kte, & - &dx(i),dz1,zw,thl,sqw,sqv,sqc,sqi,& + &dx(i),dz1,zw,u1,v1,xland(i), & + &thl,sqw,sqv,sqc,sqi, & &p1,ex1,tsq1,qsq1,cov1, & &Sh,el,bl_mynn_cloudpdf, & &qc_bl1D,qi_bl1D,cldfra_bl1D, & @@ -1193,7 +1204,7 @@ SUBROUTINE mynn_bl_driver( & 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, & + &cldfra_bl1D,rthraten(i,:), & &maxKHtopdown(i),KHtopdown,TKEprodTD ) ELSE maxKHtopdown(i) = 0.0 @@ -1311,7 +1322,6 @@ SUBROUTINE mynn_bl_driver( & !> - 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, & @@ -1326,7 +1336,7 @@ SUBROUTINE mynn_bl_driver( & &Du1, Dv1, Dth1, Dqv1, & &Dqc1, Dqi1, Dqnc1, Dqni1, & &Dqnwfa1, Dqnifa1, Dozone1, & - &vdfg(i), diss_heat, & + &diss_heat, & ! mass flux components &s_aw1,s_awthl1,s_awqt1, & &s_awqv1,s_awqc1,s_awu1,s_awv1, & @@ -1349,7 +1359,8 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) - IF ( rrfs_smoke .and. mix_chem ) THEN + IF ( mix_chem ) THEN + IF ( rrfs_sd ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1359,12 +1370,24 @@ SUBROUTINE mynn_bl_driver( & &dfh, & &s_aw1,s_awchem1, & &emis_ant_no(i), & - &frp(i), & - &fire_turb ) - + &frp(i), rrfs_sd, & + &enh_mix, smoke_dbg ) + ELSE + 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, & + &zero, & + &zero, rrfs_sd, & + &enh_mix, smoke_dbg ) + ENDIF DO ic = 1,nchem DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) + chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) ENDDO ENDDO ENDIF @@ -1373,58 +1396,38 @@ SUBROUTINE mynn_bl_driver( & &dfm, dfh, dz1, K_m1, K_h1) !UPDATE 3D ARRAYS - DO k=KTS,KTE !KTF + do k=kts,kte 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 (FLAG_QC) RQCBLTEN(i,k)=dqc1(k) - IF (FLAG_QI) RQIBLTEN(i,k)=dqi1(k) - ELSE - 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 (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 (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) - - 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 + 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 (FLAG_QC) rqcblten(i,k)=dqc1(k) + if (FLAG_QI) rqiblten(i,k)=dqi1(k) + else + 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 (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 (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) + + if (icloud_bl > 0) then + qc_bl(i,k)=qc_bl1D(k) + qi_bl(i,k)=qi_bl1D(k) + cldfra_bl(i,k)=cldfra_bl1D(k) + endif el_pbl(i,k)=el(k) qke(i,k)=qke1(k) @@ -1433,22 +1436,22 @@ SUBROUTINE mynn_bl_driver( & cov(i,k)=cov1(k) sh3d(i,k)=sh(k) sm3d(i,k)=sm(k) - ENDDO !end-k + enddo !end-k - IF ( bl_mynn_tkebudget ) 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 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 + 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 + enddo !! Upper boundary conditions k=kte qSHEAR(i,k)=0. @@ -1456,7 +1459,7 @@ SUBROUTINE mynn_bl_driver( & qWT(i,k)=0. qDISS(i,k)=0. dqke(i,k)=0. - ENDIF + endif !update updraft/downdraft properties if (bl_mynn_output > 0) THEN !research mode == 1 @@ -1495,9 +1498,9 @@ SUBROUTINE mynn_bl_driver( & 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*,& + IF ( ABS(vt(k)) > 2.0 )print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 6000.)print*,& + IF ( ABS(vq(k)) > 7000.)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) @@ -1632,22 +1635,20 @@ SUBROUTINE mym_initialize ( & 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, INTENT(IN) :: rmo, Psig_bl + REAL(kind=kind_phys), INTENT(IN) :: dx, ust, zi 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 - 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 - + REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg REAL, DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl @@ -1976,7 +1977,8 @@ SUBROUTINE mym_length ( & 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, INTENT(in) :: rmo,flt,flq,Psig_bl + REAL(kind=kind_phys), INTENT(IN) :: dx,zi 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 @@ -1986,7 +1988,7 @@ SUBROUTINE mym_length ( & 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 :: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE ! MIXING LENGTHS: @@ -2028,7 +2030,7 @@ SUBROUTINE mym_length ( & CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 - alp1 = 0.21 + alp1 = 0.23 alp2 = 1.0 alp3 = 5.0 alp4 = 100. @@ -2110,9 +2112,9 @@ SUBROUTINE mym_length ( & CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH cns = 3.5 - alp1 = 0.21 + alp1 = 0.22 !0.21 alp2 = 0.3 - alp3 = 1.5 + alp3 = 2.0 !1.5 alp4 = 5.0 alp5 = 0.3 alp6 = 50. @@ -2143,7 +2145,7 @@ SUBROUTINE mym_length ( & 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 + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2166,17 +2168,17 @@ 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) ) + alp2 = 0.3 !test+ 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) + bv = max( sqrt( gtr*dtv(k) ), 0.001) !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 & + elb = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / 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) + elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 elf = elb @@ -2215,9 +2217,9 @@ SUBROUTINE mym_length ( & 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 + alp1 = 0.22 !0.21 alp2 = 0.30 - alp3 = 1.5 + alp3 = 2.0 !1.5 alp4 = 5.0 alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length @@ -2250,7 +2252,7 @@ SUBROUTINE mym_length ( & 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 + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2276,7 +2278,7 @@ SUBROUTINE mym_length ( & 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 & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) @@ -2764,10 +2766,11 @@ 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(kind=kind_phys), 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, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu + REAL(kind=kind_phys), INTENT(IN) :: dx,zi 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 @@ -2789,7 +2792,7 @@ SUBROUTINE mym_turbulence ( & REAL :: e6c,dzk,afk,abk,vtt,vqq,& &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - REAL :: zi, cldavg + REAL :: cldavg REAL, DIMENSION(kts:kte), INTENT(in) :: theta REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod @@ -3333,12 +3336,12 @@ SUBROUTINE mym_predict (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: closure + REAL(kind=kind_phys), 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, INTENT(IN) :: flt, flq, pmz, phh + REAL(kind=kind_phys), INTENT(IN) :: ust, delt 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 @@ -3721,17 +3724,17 @@ END SUBROUTINE mym_predict !! 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 ) + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, zw, u1, v1, xland,& + & 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 ) !------------------------------------------------------------------- @@ -3742,11 +3745,12 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo + REAL, INTENT(IN) :: HFX1,rmo,xland + REAL(kind=kind_phys), INTENT(IN) :: dx,pblh1 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 + &tsq, qsq, cov, th, u1, v1 REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm @@ -3758,7 +3762,7 @@ SUBROUTINE mym_condensation (kts,kte, & 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 + &qmq,qsat_tk,wsp,wspfac INTEGER :: i,j,k REAL :: erf @@ -3769,7 +3773,8 @@ SUBROUTINE mym_condensation (kts,kte, & !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 - REAL :: lfac + REAL :: cfmax + INTEGER, PARAMETER :: buoy_opt=1 ! 0: traditional SD77, 1: CB02,CB05 !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -3971,80 +3976,69 @@ SUBROUTINE mym_condensation (kts,kte, & 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 + sgm(k) = MAX( sgm(k), qsat_tk*0.035 ) !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)))) - - END DO - - ! 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) - - !CLOUD WATER AND ICE + q1k = q1(k) ! backup Q1 for later modification + + ! Specify cloud fraction + !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 + !wayne's - over-diffuse, when limits removed from vt & vq & fng + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) + !effort to reduce rh-dependency + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(2.9*(q1(k)+0.4)))) + cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.4)))) + !moderate - best compromise?? + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*(q1(k)+0.2)))) + !closer to original for Q1 < -1, best for holding onto stratus, not good flowers + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.9*(q1(k)+0.4)))) + + + ! Specify hydrometeors + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. IF (q1k < 0.) THEN !unsaturated -#ifdef SINGLE_PREC - ql_water = sgm(k)*EXP(1.2*q1k-1.) -#else ql_water = sgm(k)*EXP(1.2*q1k-1) -#endif ql_ice = sgm(k)*EXP(1.2*q1k-1.) 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 - !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) ) + !In saturated grid cells, use average of SGS and resolved values + 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) ) - IF (cldfra_bl1D(k) < 0.01) THEN + if (cldfra_bl1D(k) < 0.01) then ql_ice = 0.0 ql_water = 0.0 cldfra_bl1D(k) = 0.0 - ENDIF + endif !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 + ! 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)/(tliq-tice))) + ! 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 @@ -4052,15 +4046,17 @@ SUBROUTINE mym_condensation (kts,kte, & !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. + qc_bl1D(k) = 0. + qi_bl1D(k) = 0. endif - ENDDO - - !Buoyancy-flux-related calculations follow... - DO k = kts,kte-1 - t = th(k)*exner(k) + !Buoyancy-flux-related calculations follow... + !limiting Q1 to avoid too much diffusion in cloud layers + if ((xland-1.5).GE.0) then ! water + q1k=max(Q1(k),-2.5) + else ! land + q1k=max(Q1(k),-2.0) + endif ! "Fng" represents the non-Gaussian transport factor ! (non-dimensional) from Bechtold et al. 1995 ! (hereafter BCMT95), section 3(c). Their suggested @@ -4072,8 +4068,7 @@ SUBROUTINE mym_condensation (kts,kte, & !ELSE ! Fng = 1.-1.5*q1k !ENDIF - !limiting to avoid mixing away stratus, was -5 - q1k=MAX(Q1(k),-1.0) + ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) IF (q1k .GE. 1.0) THEN Fng = 1.0 ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN @@ -4083,42 +4078,70 @@ SUBROUTINE mym_condensation (kts,kte, & 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). + + if (buoy_opt .eq. 1) then + cfmax= min(cldfra_bl1D(K), 0.6) + 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 - cfmax*beta*bb*Fng - 1. + vq(k) = alpha + cfmax*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). + else + + !original buoyancy flux functions from SD77 + eq1 = rrp*exp( -0.5*q1k*q1k ) + qll = max( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + q2p = xl/cp/exner(k) + + !qt is a THETA-V CONVERSION FOR TOTAL WATER + cfmax= min(cldfra_bl1D(K), 0.6) + qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cfmax + rac = alp(k)*( cfmax-qll*eq1 )*( q2p*qt-(1.+p608)*th(k) ) + + !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*th(k)-tv0 +rac + endif ! 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.) - fac_damp = min(zagl * 0.01, 1.0) + !fac_damp = min(zagl * 0.01, 1.0) + wsp =sqrt(u1(k)**2 + v1(k)**2) + wspfac = 1.0 - min(max(0.,wsp-15),10.)/10. ! reduce as winds go from 15 to 25 m/s. + fac_damp = min(zagl * 0.0025, 1.0)*wspfac !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.22 )**2 - cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 - !cld_factor = 1.0 + !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 + !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 !too low of albedo + !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 + !make this enhancement over water only? + !if ((xland-1.5).GE.0) then ! water + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) + !else + ! cld_factor = 1.0 + !endif cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) - ENDDO + enddo END SELECT !end cloudPDF option - !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + !For testing purposes only, option for isolating on the mass-flux clouds. IF (bl_mynn_cloudpdf .LT. 0) THEN DO k = kts,kte-1 cldfra_bl1D(k) = 0.0 @@ -4147,7 +4170,6 @@ END SUBROUTINE mym_condensation !! 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, & @@ -4160,7 +4182,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &dfm,dfh,dfq, & &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & &Dqnwfa,Dqnifa,Dozone, & - &vdfg1,diss_heat, & + &diss_heat, & &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & &s_awu,s_awv, & &s_awqnc,s_awqni, & @@ -4188,7 +4210,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(in) :: closure INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars @@ -4215,10 +4236,10 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &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 + REAL, INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce + REAL(kind=kind_phys), INTENT(IN) :: ust,delt,psfc,wspd !debugging - REAL ::wsp,wsp2 + REAL ::wsp,wsp2,tk2,th2 LOGICAL :: problem integer :: kproblem @@ -4234,7 +4255,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & 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 @@ -4352,7 +4372,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=u(kte) ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte ! du(k)=(d(k-kts+1)-u(k))/delt @@ -4416,7 +4437,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=v(kte) ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte ! dv(k)=(d(k-kts+1)-v(k))/delt @@ -4483,8 +4505,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=thl(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !thl(k)=d(k-kts+1) @@ -4546,8 +4568,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqw(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqw2) - CALL tridiag3(kte,a,b,c,d,sqw2) + CALL tridiag2(kte,a,b,c,d,sqw2) +! CALL tridiag3(kte,a,b,c,d,sqw2) ! DO k=kts,kte ! sqw2(k)=d(k-kts+1) @@ -4603,8 +4625,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqc(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqc2) - CALL tridiag3(kte,a,b,c,d,sqc2) + CALL tridiag2(kte,a,b,c,d,sqc2) +! CALL tridiag3(kte,a,b,c,d,sqc2) ! DO k=kts,kte ! sqc2(k)=d(k-kts+1) @@ -4681,8 +4703,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqv(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqv2) - CALL tridiag3(kte,a,b,c,d,sqv2) + CALL tridiag2(kte,a,b,c,d,sqv2) +! CALL tridiag3(kte,a,b,c,d,sqv2) ! DO k=kts,kte ! sqv2(k)=d(k-kts+1) @@ -4743,8 +4765,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqi(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqi2) - CALL tridiag3(kte,a,b,c,d,sqi2) + CALL tridiag2(kte,a,b,c,d,sqi2) +! CALL tridiag3(kte,a,b,c,d,sqi2) ! DO k=kts,kte ! sqi2(k)=d(k-kts+1) @@ -4781,8 +4803,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qni(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qni2(k)=d(k-kts+1) @@ -4821,8 +4843,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnc(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnc2(k)=d(k-kts+1) @@ -4862,8 +4884,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnwfa(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnwfa2(k)=d(k) @@ -4904,8 +4926,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnifa(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnifa2(k)=d(k-kts+1) @@ -4943,8 +4965,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & 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) + 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) @@ -5136,21 +5158,28 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & 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 + th2 = th(k) + Dth(k)*delt + tk2 = th2*exner(k) + if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then problem = .true. - print*,"Huge wind speed: i=",i," k=",k," wsp=",wsp2 - print*," du=",du(k)*delt," dv=",dv(k)*delt + print*,"Outgoing problem at: i=",i," k=",k + print*," incoming wsp=",wsp," outgoing wsp=",wsp2 + print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2 + print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004. 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)) + print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte)) endif endif @@ -5183,7 +5212,7 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real, intent(in) :: delt + real(kind=kind_phys), 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 @@ -5261,26 +5290,27 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & flt, tcd, qcd, & dfh, & s_aw, s_awchem, & - emis_ant_no,frp, & - fire_turb ) + emis_ant_no, frp, rrfs_sd, & + enh_mix, smoke_dbg ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho - REAL, INTENT(IN) :: delt,flt + REAL, INTENT(IN) :: flt + REAL(kind=kind_phys), INTENT(IN) :: delt,pblh 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 + REAL(kind=kind_phys), INTENT(IN) :: emis_ant_no,frp + LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg !local vars REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d,x + REAL, DIMENSION(kts:kte) :: a,b,c,d,x REAL :: rhs,dztop REAL :: t,dzk REAL :: hght @@ -5292,8 +5322,8 @@ 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 = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing + REAL, PARAMETER :: NO_threshold = 0.1 ! For anthropogenic sources + REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires REAL, PARAMETER :: pblh_threshold = 250.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5324,18 +5354,19 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO - !Enhance diffusion over fires - IF ( fire_turb ) THEN + !Enhanced mixing over fires + IF ( rrfs_sd .and. enh_mix ) 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 + 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 + kmaxfire = ceiling(log(frp)) 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 @@ -5354,7 +5385,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & 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)*vd1(ic)*chem1(k,ic) & & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 @@ -5371,11 +5402,14 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & c(kte)=0. d(kte)=chem1(kte,ic) - !CALL tridiag(kte,a,b,c,d) CALL tridiag3(kte,a,b,c,d,x) + IF ( smoke_dbg ) THEN + print*,'aerosol mixing ic,chem1,chem2(k,ic)',ic,(chem1(kts:kts+10,ic)),(x(kts:kts+10)) + print*,'aerosol PBL mixing ic,vd1(ic)',ic,vd1(ic) + END IF + DO k=kts,kte - !chem_new(k,ic)=d(k) chem1(k,ic)=x(k) ENDDO ENDDO @@ -5627,7 +5661,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(OUT) :: zi + REAL(kind=kind_phys), INTENT(OUT) :: zi REAL, INTENT(IN) :: landsea REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D @@ -5818,8 +5852,9 @@ 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,FLTV,FLQ,FLQV,PBLH,& - DX,Psig_shcu,landsea,ts + REAL, INTENT(IN) :: FLT,FLTV,FLQ,FLQV,& + Psig_shcu,landsea,ts + REAL(kind=kind_phys), INTENT(IN) :: dx,dt,ust,pblh LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA ! outputs - updraft properties @@ -5829,7 +5864,8 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE) :: edmf_th ! output INTEGER, INTENT(OUT) :: nup2,ktop - REAL, INTENT(OUT) :: maxmf,ztop + REAL(kind=kind_phys), INTENT(OUT) :: maxmf + REAL, INTENT(OUT) :: ztop ! outputs - variables needed for solver REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi s_awthl, & !sum ai*rho*wi*phii @@ -5847,7 +5883,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & qc_bl1d_old,cldfra_bl1d_old - INTEGER, PARAMETER :: NUP=10, debug_mf=0 + INTEGER, PARAMETER :: nup=10, debug_mf=0 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the @@ -5863,7 +5899,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,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,qtk,rho_int ! w parameters REAL,PARAMETER :: & @@ -5904,13 +5940,14 @@ SUBROUTINE DMP_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,qsat_tk,& + REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf + REAL, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, QCs, esat, qsl + REAL :: THp, QTp, QCp, QCs, esat, qsl REAL :: csigma,acfac,ac_wsp,ac_cld !plume overshoot @@ -5931,7 +5968,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& - qc_plume + qc_plume,exc_heat,exc_moist,tk_int REAL, PARAMETER :: Cdet = 1./45. REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to @@ -6200,13 +6237,28 @@ SUBROUTINE DMP_mf( & UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) 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_heat = exc_fac*UPW(1,I)*sigmaTH/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 + & + exc_heat !was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & +exc_fac*UPW(1,I)*sigmaTH/sigmaW + & + exc_heat + + !calculate exc_moist by use of surface fluxes + exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW + !calculate exc_moist by conserving rh: +! tk_int =(tk(kts)*dz(kts+1)+tk(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) +! pk =(p(kts)*dz(kts+1)+p(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) +! qtk =(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1)) +! qsat_tk = qsat_blend(tk_int, pk) ! saturation water vapor mixing ratio at tk and p +! rhgrid =MAX(MIN(1.0,qtk/MAX(1.E-8,qsat_tk)),0.001) +! tk_int = tk_int + exc_heat +! qsat_tk = qsat_blend(tk_int, pk) +! exc_moist= max(rhgrid*qsat_tk - qtk, 0.0) + UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& + & +exc_moist + UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) @@ -6299,14 +6351,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 ( mix_chem ) THEN + 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 + endif ! Define pressure at model interface Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) @@ -6479,7 +6531,7 @@ SUBROUTINE DMP_mf( & s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w !to conform to grid mean properties, move qc to qv in grid mean - !saturated layers, so total water fluxes are preserve but + !saturated layers, so total water fluxes are preserved but !negative qc fluxes in unsaturated layers is reduced. IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then qc_plume = UPQC(K,i) @@ -6697,22 +6749,22 @@ SUBROUTINE DMP_mf( & ! mym_condensation. Here, a shallow-cu component is added, but no cumulus ! clouds can be added at k=1 (start loop at k=2). DO K=KTS+1,KTE-2 - IF(k > KTOP) exit - IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN - - !interpolate plume thl, th, and qt to mass levels + IF(k > KTOP) exit + IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + !interpolate plume quantities to mass levels + Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) 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 - t = THp*exner(k) +! t = THp*exner(k) !SATURATED VAPOR PRESSURE - esat = esat_blend(t) + esat = esat_blend(tk(k)) !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) !condensed liquid in the plume on mass levels IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN - QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) + QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) ELSE QCp = MAX(edmf_qc(k),edmf_qc(k-1)) ENDIF @@ -6728,7 +6780,7 @@ SUBROUTINE DMP_mf( & b9 = a*rsl ! CB02 variable "b" q2p = xlvcp/exner(k) - pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume) bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from ! "b9" in CB02 by a factor ! of T/theta. Strictly, b9 above is formulated in @@ -6748,17 +6800,32 @@ SUBROUTINE DMP_mf( & endif !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 = 3.5E-3 * Aup * 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) + !sigq = 4. * Aup * (QTp - qt(k)) + !constrain sigq wrt saturation: + sigq = max(sigq, qsat_tk*0.02 ) + sigq = min(sigq, qsat_tk*0.25 ) 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) + Q1 = qmq/sigq ! the numerator of Q1 + + if ((landsea-1.5).GE.0) then ! WATER + mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) + mf_cf = max(mf_cf, 1.2 * Aup) + else ! LAND + !mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) ! New WA fit + mf_cf = max(mf_cf, 1.75 * Aup) + endif + + ! WA TEST 4/15/22 use fit to Aup rather than CB + !IF (Aup > 0.1) THEN + ! mf_cf = 2.5 * Aup + !ELSE + ! mf_cf = 1.8 * Aup + !ENDIF !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" @@ -6769,61 +6836,64 @@ SUBROUTINE DMP_mf( & !ENDIF ! Update cloud fractions and specific humidities in grid cells - ! where the mass-flux scheme is active. Now, we also use the - ! stratus component of the SGS clouds as well. The stratus cloud - ! fractions (Ac_strat) are reduced slightly to give way to the - ! mass-flux SGS cloud fractions (Ac_mf). - IF (cldfra_bl1d(k) < 0.5) THEN - IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN - !cldfra_bl1d(k) = mf_cf - !qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - Ac_mf = mf_cf - Ac_strat = cldfra_bl1d(k)*(1.0-mf_cf) - cldfra_bl1d(k) = Ac_mf + Ac_strat - !dillute Qc from updraft area to larger cloud area - qc_mf = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - !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 = 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)) - !qc_bl1d(k) = QCp - Ac_mf = 0.5*(edmf_a(k)+edmf_a(k-1)) - Ac_strat = cldfra_bl1d(k)*(1.0-Ac_mf) - cldfra_bl1d(k)=Ac_mf + Ac_strat - qc_mf = QCp - !Ensure stratus clouds have mixing ratio similar to cumulus - QCs = MAX(qc_bl1d(k), 0.5*qc_mf) - qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) - ENDIF - ELSE - Ac_mf = mf_cf - ENDIF + ! where the mass-flux scheme is active. The specific humidities + ! are converted to grid means (not in-cloud quantities). + + if ((landsea-1.5).GE.0) then ! water + !don't overwrite stratus CF & qc_bl - degrades marine stratus + if (cldfra_bl1d(k) < cf_thresh) then + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + if (mf_cf .ge. Aup) then + qc_bl1d(k) = qc_bl1d(k) / mf_cf + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif + else ! land + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + if (mf_cf .ge. Aup) then + qc_bl1d(k) = qc_bl1d(k) / mf_cf + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif !Now recalculate the terms for the buoyancy flux for mass-flux clouds: - !See mym_condensation for details on these formulations. The - !cloud-fraction bounding was added to improve cloud retention, - !following RAP and HRRR testing. - !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) - !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: - Q1 = qmq/MAX(sigq,1E-6) - Q1=MAX(Q1,-5.0) - IF (Q1 .GE. 1.0) THEN - Fng = 1.0 - ELSEIF (Q1 .GE. -1.7 .AND. Q1 .LT. 1.0) THEN - Fng = EXP(-0.4*(Q1-1.0)) - ELSEIF (Q1 .GE. -2.5 .AND. Q1 .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - ENDIF + !See mym_condensation for details on these formulations. + !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with + !limits ,since they really should be recalculated after all the other changes...: + !Only overwrite vt & vq in non-stratus condition + if (cldfra_bl1d(k) < cf_thresh) then + !if ((landsea-1.5).GE.0) then ! WATER + Q1=max(Q1,-2.25) + !else + ! Q1=max(Q1,-2.0) + !endif + + if (Q1 .ge. 1.0) then + Fng = 1.0 + elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then + Fng = EXP(-0.4*(Q1-1.0)) + elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + else + Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) + endif - vt(k) = qww - MIN(0.40,Ac_mf)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(0.40,Ac_mf)*beta*a*Fng - tv0 - ENDIF - ENDDO + !link the buoyancy flux function to active clouds only (c*Aup): + vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. + vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + endif + endif + enddo !k-loop ENDIF !end nup2 > 0 @@ -6997,11 +7067,12 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & INTEGER, INTENT(IN) :: KTS,KTE,KPBL REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& - THV,P,rho,exner,rthraten,dz + THV,P,rho,exner,dz + REAL(kind=kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - REAL, INTENT(IN) :: DT,UST,WTHL,WQT,PBLH - + REAL, INTENT(IN) :: WTHL,WQT + REAL(kind=kind_phys), INTENT(IN) :: dt,ust,pblh ! outputs - downdraft properties REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd @@ -7352,7 +7423,7 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - REAL,INTENT(IN) :: dx,PBL1 + REAL(kind=kind_phys), INTENT(IN) :: dx,pbl1 REAL, INTENT(OUT) :: Psig_bl,Psig_shcu REAL :: dxdh @@ -7628,9 +7699,11 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & !input integer, intent(in) :: kte,kts real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& - thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D,rthraten + thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D + real(kind=kind_phys), dimension(kts:kte), intent(in) :: rthraten real, dimension(kts:kte+1), intent(in) :: zw - real, intent(in) :: pblh,xland + real(kind=kind_phys), intent(in) :: pblh + real, intent(in) :: xland integer,intent(in) :: kpbl !output real, intent(out) :: maxKHtopdown diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 70c48feba1..ada4df0e19 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -2244,7 +2244,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ni(k) = MAX(R2, ni1d(k)*rho(k)) if (ni(k).le. R2) then lami = cie(2)/5.E-6 - ni(k) = MIN(4999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif L_qi(k) = .true. lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi @@ -2252,7 +2252,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - ni(k) = MIN(4999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -2458,7 +2458,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ do k = kte, kts, -1 ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + zans1 = 3.3 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 @@ -2954,7 +2954,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Freezing of aqueous aerosols based on Koop et al (2001, Nature) xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if ((is_aerosol_aware .or. merra2_aerosol_aware) .AND. homogIce .AND. (xni.le.4999.E3) & + if ((is_aerosol_aware .or. merra2_aerosol_aware) .AND. homogIce .AND. (xni.le.999.E3) & & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts @@ -3290,7 +3290,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(4999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = MIN(999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -3301,8 +3301,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.4999.E3) & - niten(k) = (4999.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.999.E3) & + niten(k) = (999.E3-ni1d(k)*rho(k))*odts*orho !> - Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -3537,7 +3537,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ do k = kte, kts, -1 ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + zans1 = 3.3 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 @@ -4174,7 +4174,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtg = 0. if (rg(k).gt. R1) then ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + zans1 = 3.3 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 @@ -4274,7 +4274,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = cie(2)/300.E-6 endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 4999.D3/rho(k)) + 999.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) @@ -6077,7 +6077,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & if (ANY(L_qg .eqv. .true.)) then do k = kte, kts, -1 ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + zans1 = 3.3 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index c0457c20aa..32af12bffb 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -66,6 +66,7 @@ MODULE module_sf_mynn ! & p1000mb, ep_2 ! !For non-WRF + use machine, only : kind_phys use physcons, only : cp => con_cp, & & g => con_g, & & r_d => con_rd, & @@ -138,6 +139,7 @@ SUBROUTINE SFCLAY_mynn( & z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) itimestep,iter,flag_iter, & !in + flag_restart, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -273,10 +275,10 @@ SUBROUTINE SFCLAY_mynn( & REAL(kind=kind_phys), INTENT(IN) :: EP1,EP2,KARMAN REAL(kind=kind_phys), 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 - logical, intent(in) :: compute_flux,compute_diag + integer, intent(in) :: ISFFLX, LSM, LSM_RUC + 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) @@ -337,6 +339,7 @@ SUBROUTINE SFCLAY_mynn( & LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & & wet, dry, icy, flag_iter + LOGICAL, INTENT(IN) :: flag_restart REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(IN) :: & & tskin_wat, tskin_lnd, tskin_ice, & @@ -416,11 +419,19 @@ SUBROUTINE SFCLAY_mynn( & IF (itimestep==1 .AND. iter==1) THEN DO i=its,ite - !Everything here is used before calculated - UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - MOL(i)=0.0 + IF (.not. flag_restart) THEN + !Everything here is used before calculated + if (ust_wat(i) .lt. 1e-4 .or. ust_wat(i) .gt. 3.0) then + UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.0.001_kind_phys) + endif + if (ust_lnd(i) .lt. 1e-4 .or. ust_lnd(i) .gt. 3.0) then + UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.0.001_kind_phys) + endif + if (ust_ice(i) .lt. 1e-4 .or. ust_ice(i) .gt. 3.0) then + UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.0.001_kind_phys) + endif + MOL(i)=0.0 + ENDIF ! restart QFLX(i)=0. HFLX(i)=0. if ( LSM == LSM_RUC ) then @@ -447,7 +458,7 @@ SUBROUTINE SFCLAY_mynn( & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -495,7 +506,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -535,6 +546,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & J, itimestep, iter, lsm, lsm_ruc + LOGICAL, INTENT(IN) :: flag_restart REAL(kind=kind_phys), PARAMETER :: XKA=2.4E-5 !molecular diffusivity REAL(kind=kind_phys), PARAMETER :: PRT=1. !prandlt number @@ -969,13 +981,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_wat(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_wat*WSPD_wat) - IF (ITIMESTEP == 1) THEN - rb_wat(I)=MAX(rb_wat(I),-2.0_kind_phys) - rb_wat(I)=MIN(rb_wat(I), 2.0_kind_phys) - ELSE - rb_wat(I)=MAX(rb_wat(I),-4.0_kind_phys) - rb_wat(I)=MIN(rb_wat(I), 4.0_kind_phys) - ENDIF + rb_wat(I)=MAX(rb_wat(I),-2.0_kind_phys) + rb_wat(I)=MIN(rb_wat(I), 2.0_kind_phys) ENDIF ! end water point IF (dry(i)) THEN @@ -1012,13 +1019,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !ELSE ! ust_lnd(i)=WSPD_lnd*0.1*(1.0 - 10.0*rb_lnd(I))**onethird !ENDIF - IF (ITIMESTEP == 1) THEN - rb_lnd(I)=MAX(rb_lnd(I),-2.0_kind_phys) - rb_lnd(I)=MIN(rb_lnd(I), 2.0_kind_phys) - ELSE - rb_lnd(I)=MAX(rb_lnd(I),-4.0_kind_phys) - rb_lnd(I)=MIN(rb_lnd(I), 4.0_kind_phys) - ENDIF + rb_lnd(I)=MAX(rb_lnd(I),-2.0_kind_phys) + rb_lnd(I)=MIN(rb_lnd(I), 2.0_kind_phys) ENDIF ! end land point IF (icy(i)) THEN @@ -1049,13 +1051,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_ice(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_ice*WSPD_ice) - IF (ITIMESTEP == 1) THEN - rb_ice(I)=MAX(rb_ice(I),-2.0_kind_phys) - rb_ice(I)=MIN(rb_ice(I), 2.0_kind_phys) - ELSE - rb_ice(I)=MAX(rb_ice(I),-4.0_kind_phys) - rb_ice(I)=MIN(rb_ice(I), 4.0_kind_phys) - ENDIF + rb_ice(I)=MAX(rb_ice(I),-2.0_kind_phys) + rb_ice(I)=MIN(rb_ice(I), 2.0_kind_phys) ENDIF ! end ice point !NOW CONDENSE THE POSSIBLE WSPD VALUES BY TAKING THE MAXIMUM @@ -1338,27 +1335,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(i)) THEN IF (rb_wat(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1404,26 +1403,28 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !========================================================== !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1471,27 +1472,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (dry(i)) THEN IF (rb_lnd(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1535,27 +1538,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1602,27 +1607,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(i)) THEN IF (rb_ice(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1666,27 +1673,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 9a6363c08f..676f49b2cb 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -25,6 +25,16 @@ MODULE module_sf_ruclsm real (kind=kind_phys), parameter :: piconst = 3.1415926535897931 real (kind=kind_phys), parameter :: r_v = 4.6150e+2 + !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 + integer, parameter :: isncond_opt = 2 + + !-- Snow fraction options + !-- option 1: original formulation using critical snow depth to compute snow fraction + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. + integer, parameter :: isncovr_opt = 1 + +!! @} + !> VEGETATION PARAMETERS INTEGER :: LUCATS integer, PARAMETER :: NLUS=50 @@ -49,12 +59,13 @@ MODULE module_sf_ruclsm !>\ingroup lsm_ruc_group !> The RUN LSM model is described in Smirnova et al.(1997) !! \cite Smirnova_1997 and Smirnova et al.(2000) \cite Smirnova_2000 -!>\section gen_lsmruc_ga RUC LSM General Algorithm - SUBROUTINE LSMRUC( & +!>\section gen_lsmruc GSD RUC LSM General Algorithm +!! @{ + SUBROUTINE LSMRUC(xlat,xlon, & DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & - rhosnf,precipfr, & + rhosnf,precipfr, hgt,stdev, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT, & @@ -66,7 +77,8 @@ SUBROUTINE LSMRUC( & ISWATER,ISICE,XICE,XICE_THRESHOLD, & CP,RV,RD,G0,PI,LV,STBOLT, & SOILMOIS,SH2O,SMAVAIL,SMMAX, & - TSO,SOILT,HFX,QFX,LH,INFILTR, & + TSO,SOILT,EDIR,EC,ETT,SUBLIM,SNOH, & + HFX,QFX,LH,INFILTR, & RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, & SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & @@ -124,7 +136,7 @@ SUBROUTINE LSMRUC( & !-- XLAND land mask (1 for land, 2 for water) !-- CP heat capacity at constant pressure for dry air (J/kg/K) !-- G0 acceleration due to gravity (m/s^2) -!-- LV latent heat of melting (J/kg) +!-- LV latent heat of evaporation (J/kg) !-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) ! SOILMOIS - soil moisture content (volumetric fraction) ! TSO - soil temp (K) @@ -135,9 +147,9 @@ SUBROUTINE LSMRUC( & ! SFCRUNOFF - ground surface runoff [mm] ! UDRUNOFF - underground runoff [mm] ! ACRUNOFF - run-total surface runoff [mm] -! SFCEVP - total evaporation in [kg/m^2] +! SFCEVP - total time-step evaporation in [kg/m^2] ! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) -! SNOWFALLAC - run-total snowfall accumulation [m] +! SNOWFALLAC - run-total snowfall accumulation [mm] ! ACSNOW - run-toral SWE of snowfall [mm] !-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). !-- used only in MYJPBL. @@ -156,6 +168,7 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) + REAL, INTENT(IN ) :: xlat,xlon REAL, INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil @@ -198,6 +211,8 @@ SUBROUTINE LSMRUC( & REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS @@ -239,6 +254,11 @@ SUBROUTINE LSMRUC( & HFX, & QFX, & LH, & + EDIR, & + EC, & + ETT, & + SUBLIM, & + SNOH, & SFCEVP, & RUNOFF1, & RUNOFF2, & @@ -267,12 +287,7 @@ SUBROUTINE LSMRUC( & ZNTL, & LMAVAIL, & SMELT, & - SNOH, & SNFLX, & - EDIR, & - EC, & - ETT, & - SUBLIM, & sflx, & smf, & EVAPL, & @@ -382,6 +397,9 @@ SUBROUTINE LSMRUC( & INTEGER :: k1,k2 logical :: debug_print + !-- diagnostic point + real (kind=kind_phys) :: testptlat, testptlon + !----------------------------------------------------------------- ! debug_print = .false. @@ -391,6 +409,12 @@ SUBROUTINE LSMRUC( & NZS=NSL NDDZS=2*(nzs-2) + !-- + testptlat = 41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 284.50 !286.75 !280.6 !164.0 !283.0 + !-- + + !> - Table TBQ is for resolution of balance equation in vilka() CQ=173.15-.05 R273=1./273.15 @@ -414,44 +438,50 @@ SUBROUTINE LSMRUC( & !> - Initialize soil/vegetation parameters !--- This is temporary until SI is added to mass coordinate ---!!!!! - if(init .and. (lsm_cold_start) .and. iter == 1) then - DO J=jts,jte + if(init .and. iter == 1) then + + if( lsm_cold_start ) then + !-- beginning of cold-start + DO J=jts,jte DO i=its,ite -! do k=1,nsl -! keepfr3dflag(i,k,j)=0. -! enddo -!> - Initializing snow fraction, thereshold = 32 mm of snow water -!! or ~100 mm of snow height ! -! snowc(i,j) = min(1.,snow(i,j)/32.) -! soilt1(i,j)=soilt(i,j) -! if(snow(i,j).le.32.) soilt1(i,j)=tso(i,1,j) -!> - Initializing inside snow temp if it is not defined - IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN - IF(snow(i,j).gt.32.) THEN - soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j)) - IF (debug_print ) THEN - print *, & - 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,j - ENDIF - ELSE - soilt1(i,j) = tso(i,1,j) - ENDIF - ENDIF - tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.15 - qcg (i,j) =0. +!> - Initializing inside-snow temp if it is not defined + IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN + IF(snowc(i,j).gt.0.) THEN + soilt1(i,j)=min(273.15,0.5*(soilt(i,j)+tso(i,1,j)) ) + IF (debug_print ) THEN + print *, & + 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon + ENDIF + ELSE + soilt1(i,j) = tso(i,1,j) + ENDIF + ENDIF + tsnav(i,j) =min(0.,0.5*(soilt(i,j)+tso(i,1,j))-273.15) + !- 10feb22 - limit snow albedo at high elevations + !- based on Roesch et al., Climate Dynamics (2001),17:933-946 + if(hgt(i,j) > 2500.) then + snoalb(i,j) = min(0.65,snoalb(i,j)) + endif + patmb=P8w(i,kms,j)*1.e-2 QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - IF((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) THEN - !17sept19 - bad approximation with very low mavail. - !qvg(i,j) = QSG(i,j)*mavail(i,j) - qvg (i,j) = qv3d(i,1,j) - IF (debug_print ) THEN - print *, & - 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,j - ENDIF - ENDIF -! qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + + if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then + qcg (i,j) = qc3d(i,1,j) + if (debug_print ) then + print *, 'QCG is initialized in RUCLSM ', qcg(i,j),qc3d(i,1,j),i,xlat,xlon + endif + endif + + if((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) then + qvg (i,j) = qv3d(i,1,j) + if (debug_print ) then + print *, 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,xlat,xlon + endif + endif + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + SMELT(i,j) = 0. SNOM (i,j) = 0. ACSNOW(i,j) = 0. @@ -474,8 +504,6 @@ SUBROUTINE LSMRUC( & acwaterbudget(i,j) = 0. smtotold(i,j)=0. canwatold(i,j)=0. -! Temporarily!!! -! canwat(i,j)=0. !> - For RUC LSM CHKLOWQ needed for MYJPBL should !! 1 because is actual specific humidity at the surface, and @@ -492,20 +520,14 @@ SUBROUTINE LSMRUC( & evapl (i,j) = 0. prcpl (i,j) = 0. ENDDO - ENDDO - - infiltrp = 0. - do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. - enddo - else ! .not. init==true. - DO J=jts,jte - DO i=its,ite - SFCRUNOFF(i,j) = 0. - UDRUNOFF(i,j) = 0. - ENDDO ENDDO + + infiltrp = 0. + do k=1,nsl + soilice(k)=0. + soiliqw(k)=0. + enddo + endif ! cold start endif ! init==.true. !----------------------------------------------------------------- @@ -522,22 +544,16 @@ SUBROUTINE LSMRUC( & DO i=its,ite IF (debug_print ) THEN -! if(j==10) then - print *,' IN LSMRUC ','ims,ime,jms,jme,its,ite,jts,jte,nzs', & - ims,ime,jms,jme,its,ite,jts,jte,nzs - print *,' IVGTYP, ISLTYP ', ivgtyp(i,j),isltyp(i,j) - print *,' MAVAIL ', mavail(i,j) - print *,' SOILT,QVG,P8w',soilt(i,j),qvg(i,j),p8w(i,1,j) - print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), & - qfx(i,j),hfx(i,j) - print *, ' GSW, GLW =',gsw(i,j),glw(i,j) - print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) - print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl) - print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl) - print *, ' I,J=, after SFCLAY CHS,FLHC ',i,j,chs(i,j),flhc(i,j) - print *, 'LSMRUC, IVGTYP,ISLTYP,ALB = ', ivgtyp(i,j),isltyp(i,j),alb(i,j),i,j - print *, 'LSMRUC I,J,DT,RAINBL =',I,J,dt,RAINBL(i,j) - print *, 'XLAND ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC start) i=',i,' lat,lon=',xlat,xlon, & + 'mavail ', mavail(i,j),' soilt',soilt(i,j),'qvg ',qvg(i,j),& + 'p8w',p8w(i,1,j),'sflay qfx',qfx(i,j),'sflay hfx',hfx(i,j),& + 'gsw ',gsw(i,j),'glw ',glw(i,j),'soilt ',soilt(i,j), & + 'chs ',chs(i,j),'flqc ',flhc(i,j),'alb ',alb(i,j), & + 'rainbl ',rainbl(i,j),'dt ',dt + print *,'nzs',nzs, 'ivgtyp ',ivgtyp(i,j),'isltyp ',isltyp(i,j) + endif ENDIF @@ -646,7 +662,10 @@ SUBROUTINE LSMRUC( & NZS1=NZS-1 !----- IF (debug_print ) THEN - print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + endif ENDIF DO K=2,NZS1 @@ -685,7 +704,7 @@ SUBROUTINE LSMRUC( & ! ! rooting depth RHONEWSN = 200. - if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.) then + if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.02) then RHOSN = SNOW(i,j)/SNOWH(i,j) else RHOSN = 300. @@ -693,8 +712,11 @@ SUBROUTINE LSMRUC( & IF (debug_print ) THEN if(init) then - print *,'before SOILVEGIN - z0,znt(195,254)',z0(i,j),znt(i,j) - print *,'ILAND, ISOIL =',i,j,iland,isoil + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'before SOILVEGIN - z0,znt',i,z0(i,j),znt(i,j) + print *,'ILAND, ISOIL =',i,iland,isoil + endif endif ENDIF @@ -710,21 +732,21 @@ SUBROUTINE LSMRUC( & EMISBCK(I,J) = EMISSL(I,J) IF (debug_print ) THEN - if(init) & - print *,'after SOILVEGIN - z0,znt(1,26),lai(1,26)',z0(i,j),znt(i,j),lai(i,j) - if(init)then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'after SOILVEGIN - z0,znt,lai',i,z0(i,j),znt(i,j),lai(i,j) print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j print *,'NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',& NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j + endif endif ENDIF CN=CFACTR_DATA ! exponent ! SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated SAT = 5.e-4 ! units [m] -! if(i==666.and.j==282) print *,'second 666,282 - sat',sat !-- definition of number of soil levels in the rooting zone ! IF(iforest(ivgtyp(i,j)).ne.1) THEN @@ -811,7 +833,6 @@ SUBROUTINE LSMRUC( & ! LAND POINT OR SEA ICE if(xice(i,j).ge.xice_threshold) then -! if(IVGTYP(i,j).eq.isice) then SEAICE(i,j)=1. else SEAICE(i,j)=0. @@ -873,24 +894,34 @@ SUBROUTINE LSMRUC( & LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin))) IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & - i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO - print *,'CONFLX =',CONFLX - print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & + i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO + print *,'CONFLX =',CONFLX + print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + endif ENDIF smtotold(i,j)=0. - do k=1,nzs-1 + + !do k=1,nzs-1 + do k=1,nroot smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) enddo - smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) + !smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print .and. abs(xlat-testptlat).lt.0.2 & + .and. abs(xlon-testptlon).lt.0.2) then + print *,'Old soilm1d ',i,soilm1d + endif canwatold(i,j) = canwatr !----------------------------------------------------------------- CALL SFCTMP (debug_print, dt,ktau,conflx,i,j, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & @@ -902,7 +933,8 @@ SUBROUTINE LSMRUC( & EMISSL(I,J),EMISBCK(I,J), & QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & canwatr,vegfra(I,J),alb(I,J),znt(I,J), & - snoalb(i,j),albbck(i,j),lai(i,j), & !new + snoalb(i,j),albbck(i,j),lai(i,j), & + hgt(i,j),stdev(i,j), & !new myj,seaice(i,j),isice, & !--- soil fixed fields QWRTZ, & @@ -978,25 +1010,38 @@ SUBROUTINE LSMRUC( & smavail(i,j) = 0. smmax (i,j) = 0. - do k=1,nzs-1 + !do k=1,nzs-1 + !-- root-zone soil moisture + do k=1,nroot smavail(i,j)=smavail(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) smmax (i,j) =smmax (i,j)+(qmin+dqm)* & (zshalf(k+1)-zshalf(k)) enddo - smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) - smmax (i,j) =smmax (i,j)+(qmin+dqm)* & - (zsmain(nzs)-zshalf(nzs)) + !smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + !smmax (i,j) =smmax (i,j)+(qmin+dqm)* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC runoff) i=',i,' lat,lon=',xlat,xlon, & + 'RUNOFF1', RUNOFF1(I,J), 'RUNOFF2 ',RUNOFF2(I,J), & + 'edir ',edir(I,J),'ec ',ec(I,J),'ett ',ett(I,J) + endif + endif !--- Convert the water unit into mm - SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - ACRUNOFF(I,J) = ACRUNOFF(I,J)+(RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. + !-- three lines below are commented because accumulation + ! happens in sfc_drv_ruc + !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 + !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 + !ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff + SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. - smtotold (I,J) = smtotold(I,J) * 1000. + smtotold (I,J) = smtotold(I,J) * 1000. ! mm do k=1,nzs @@ -1016,7 +1061,7 @@ SUBROUTINE LSMRUC( & !tgs add together dew and cloud at the ground surface !30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms - Z0 (I,J) = ZNT (I,J) + !Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS patmb=P8w(i,1,j)*1.e-2 Q2SAT=QSN(TABS,TBQ)/PATMB @@ -1033,13 +1078,6 @@ SUBROUTINE LSMRUC( & ! CHKLOWQ(I,J)=1. ! endif - IF (debug_print ) THEN - if(CHKLOWQ(I,J).eq.0.) then - print *,'i,j,CHKLOWQ', & - i,j,CHKLOWQ(I,J) - endif - ENDIF - if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m @@ -1047,14 +1085,18 @@ SUBROUTINE LSMRUC( & SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. -if (debug_print) then - print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) -endif + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) + endif + endif INFILTR(I,J) = INFILTRP MAVAIL (i,j) = LMAVAIL(I,J) IF (debug_print ) THEN - print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !!! QFX (I,J) = LH(I,J)/LV SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT @@ -1068,9 +1110,9 @@ SUBROUTINE LSMRUC( & ! endif !--- SNOWC snow cover flag - if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then - SNOWFRAC = SNOWFRAC*XICE(I,J) - endif + !if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then + ! SNOWFRAC = SNOWFRAC*XICE(I,J) + !endif SNOWC(I,J)=SNOWFRAC @@ -1092,20 +1134,34 @@ SUBROUTINE LSMRUC( & ! endif ! budget(i,j)=budget(i,j)-smf(i,j) + if (debug_print ) then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + !-- compute budget for a test point ac=0. as=0. + wb=0. - ac=max(0.,canwat(i,j)-canwatold(i,j)*1.e3) - as=max(0.,snwe-snowold(i,j)) - wb =rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source - -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) - + ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change + as=snwe-snowold(i,j) ! SWE change + wb = smavail(i,j)-smtotold(i,j) waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source -qfx(i,j)*dt & -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) + -ac-as ! - (smavail(i,j)-smtotold(i,j)) + + print *,'soilm1d ',i,soilm1d + print 100,'(RUC budgets) i=',i,' lat,lon=',xlat,xlon, & + 'budget ',budget(i,j),'waterbudget',waterbudget(i,j), & + 'rainbl ',rainbl(i,j),'runoff1 ',runoff1(i,j), & + 'smelt ',smelt(i,j)*dt*1.e3,'smc change ',wb, & + 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & + 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) + !-- + ! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & @@ -1115,27 +1171,29 @@ SUBROUTINE LSMRUC( & !!!!TEST use LH to check water budget ! GRDFLX (I,J) = waterbudget(i,j) - IF (debug_print ) THEN - print *,'Smf=',smf(i,j),i,j - print *,'Budget',budget(i,j),i,j - print *,'RUNOFF2= ', i,j,runoff2(i,j) - print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb - print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & - i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & - smelt(i,j)*dt*1.e3, & - (smavail(i,j)-smtotold(i,j)) - - print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) - print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) - print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) - print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) - ENDIF +! print *,'Smf=',smf(i,j),i,j +! print *,'Budget',budget(i,j),i,j +! print *,'RUNOFF2= ', i,j,runoff2(i,j) +! print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb +! print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & +! i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & +! smelt(i,j)*dt*1.e3, & +! (smavail(i,j)-smtotold(i,j)) +! +! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) +! print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) +! print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) +! print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) +! ENDIF IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & i,j,tso1d,soilm1d,soilt(i,j) - print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !--- end of a land or sea ice point @@ -1159,6 +1217,7 @@ END SUBROUTINE LSMRUC !! the snow "mosaic" approach is turned on. !! - Updates emissivity and albedo for patch snow. SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input variables + xlat,xlon,testptlat,testptlon, & nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & @@ -1167,7 +1226,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia PATM,TABS,QVATM,QCATM,rho, & GLW,GSWdn,GSW,EMISS,EMISBCK,QKMS,TKMS,PC, & MAVAIL,CST,VEGFRA,ALB,ZNT, & - ALB_SNOW,ALB_SNOW_FREE,lai, & + ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, & MYJ,SEAICE,ISICE, & QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1189,7 +1248,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor + REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + REAL, INTENT(IN ) :: testptlat,testptlon REAL, INTENT(IN ) :: C1SN,C2SN LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables @@ -1206,6 +1266,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia VEGFRA, & ALB_SNOW_FREE, & lai, & + hgt,stdev, & SEAICE, & RHO, & QKMS, & @@ -1378,11 +1439,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SNWE,RHOSN,SNOM,SMELT,TS1D ENDIF + !-- Snow fraction options + !-- option 1: original formulation using critical snow depth to compute + !-- snow fraction + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674. + !isncovr_opt = 1 + !-- + !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 + snhei_crit=0.01601*1.e3/rhosn + snhei_crit_newsn=0.0005*1.e3/rhosn + !-- + zntsn = z0tbl(isice) snow_mosaic=0. snfr = 1. NEWSN=0. newsnowratio = 0. snowfracnewsn=0. + rhonewsn = 100. if(snhei == 0.) snowfrac=0. smelt = 0. RAINF = 0. @@ -1454,23 +1527,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(bsn*snwe*100..lt.1.e-4) goto 777 XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(62.5,XSN),890.) -! rhosn=MIN(MAX(100.,XSN),400.) -! rhosn=MIN(MAX(50.,XSN),400.) 777 continue - -! else -! rhosn =200. -! rhonewsn =200. endif + !-- snow_mosaic from the previous time step + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. + newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] acsnow=acsnow+newsn*1.e3 IF(NEWSN.GT.0.) THEN -! IF(NEWSN.GE.1.E-8) THEN IF (debug_print ) THEN print *, 'THERE IS NEW SNOW, newsn', newsn @@ -1478,18 +1546,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia newsnowratio = min(1.,newsn/(snwe+newsn)) -!*** Calculate fresh snow density (t > -15C, else MIN value) -!*** Eq. 10 from Koren et al. (1999) -!--- old formulation from Koren (1999) -! if(tabs.lt.258.15) then -! rhonewsn=50. -! rhonewsn=100. -! rhonewsn=62.5 - -! else -! rhonewsn=MIN(rhonewsn,400.) -! endif -!--- end of old formulation + if(isncovr_opt == 2) then + !-- update snow fraction for fresh snowfall (Swenson&Lawrence,JGR,2012) + ! time-step snowfall [mm H2O], 0.1 - accumulation constant (unitless) + snowfrac = snowfrac + tanh(0.1*newsn*1.e3)*(1.-snowfrac) ! eq. 8.1 from CLM5 + if(debug_print) print *,'2 - snowfrac newsn', i,j,ktau,snowfrac + endif !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) @@ -1505,6 +1567,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) + if (debug_print) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,'snow_mosaic = ',snow_mosaic + print *,'new snow,newsnowratio,rhosnfall =',newsn,newsnowratio,rhosnfall + print *,'snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice',snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice + endif ! from now on rhonewsn is the density of falling frozen precipitation rhonewsn=rhosnfall @@ -1514,15 +1583,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(100.,XSN),500.) -! rhosn=MIN(MAX(50.,XSN),400.) - -!Update snow on the ground -! snwe=snwe+newsn -! newsnowratio = min(1.,newsn/snwe) -! snhei=snwe*rhowater/rhosn -! NEWSN=NEWSN*rhowater/rhonewsn ENDIF ! end NEWSN > 0. IF(PRCPMS.NE.0.) THEN @@ -1543,9 +1603,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! J. of Hydrometeorology, 2006, CLM. interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac -!original - next 2 lines -! interw=DELT*PRCPMS*vegfrac -! intersn=NEWSN*vegfrac infwater=PRCPMS - interw/delt if((interw+intersn) > 0.) then intwratio=interw/(interw+intersn) @@ -1554,7 +1611,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! Update water/snow intercepted by the canopy dd1=CST + interw + intersn CST=DD1 -! if(i==666.and.j==282) print *,'666,282 - cst,sat,interw,intersn',cst,sat,interw,intersn IF(CST.GT.SAT) THEN CST=SAT DRIP=DD1-SAT @@ -1567,12 +1623,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infwater=PRCPMS endif ! vegfrac > 0.01 -! SNHEI_CRIT is a threshold for fractional snow - SNHEI_CRIT=0.01601*1.e3/rhosn - SNHEI_CRIT_newsn=0.0005*1.e3/rhosn -! snowfrac from the previous time step - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) - if(snowfrac < 0.75) snow_mosaic = 1. IF(NEWSN.GT.0.) THEN !Update snow on the ground @@ -1609,9 +1659,11 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! SNHEI_CRIT_newsn=0.001*1.e3/rhosn ! endif - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -!24nov15 - SNOWFRAC for urban category < 0.75 - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + if(isncovr_opt == 1) then + !-- update snow cover with accounting for fresh snow + snowfrac=min(1.,snhei/(2.*snhei_crit)) + endif + ! if(meltfactor > 1.5) then ! if(isltyp > 9 .and. isltyp < 13) then !24nov15 clay soil types - SNOFRAC < 0.9 @@ -1622,16 +1674,22 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snowfrac=min(0.85,snowfrac) ! endif -! SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -! elseif(snowfrac < 0.3 .and. tabs > 275.) then -! if(snowfrac < 0.3.and. tabs > 275.) snow_mosaic = 1. + if(newsn > 0. ) then + SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + endif - if(snowfrac < 0.75) snow_mosaic = 1. + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains to 0.85 (based on Swiss weather model over the Alps) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) - if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + !24nov15 - SNOWFRAC for urban category < 0.75 + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. + + KEEP_SNOW_ALBEDO = 0. + IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN ! new snow KEEP_SNOW_ALBEDO = 1. snow_mosaic=0. ! ??? @@ -1650,14 +1708,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). -!5mar12 IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) -! IF(newsn==0. .and. znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then if( snhei .le. 2.*ZNT)then + ! shallow snow znt=0.55*znt+0.45*z0tbl(iland) elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then znt=0.2*znt+0.8*z0tbl(iland) elseif(snhei > 4.*ZNT) then + ! deep snow znt=z0tbl(iland) endif ENDIF @@ -1687,8 +1745,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia (emissn - emiss_snowfree) * snowfrac), emissn)) endif IF (debug_print ) THEN -! if(i.eq.279.and.j.eq.263) then - print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic ENDIF !28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is ! higher than patchy snow treshold - then snow albedo is not less than 0.55 @@ -1756,7 +1814,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1780,7 +1837,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ilands = ivgtyp - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & @@ -1811,7 +1868,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1826,7 +1882,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia runoff1s=0. runoff2s=0. - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -1857,34 +1913,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia enddo endif ! seaice < 0.5 -!return gswnew to incoming solar - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb - ENDIF -! gswnew=gswnew/(1.-alb_snow_free) - - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'Incoming GSWnew snowfrac<1 -',gswnew - ENDIF endif ! snow_mosaic=1. !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB gswnew=GSWin*(1.-alb) -! print *,'SNOW fraction GSWnew',gswnew,'alb=',alb !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT XINET = EMISS*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then -! if(i.eq.271.and.j.eq.242) then print *,'RNET=',rnet print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',& i,j,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB + print *,'GSWnew',gswnew,'alb=',alb ENDIF if (SEAICE .LT. 0.5) then @@ -1894,7 +1937,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia else snfr=snowfrac endif - CALL SNOWSOIL (debug_print, & !--- input variables + CALL SNOWSOIL (debug_print,xlat,xlon, & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1924,7 +1967,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snfr=snowfrac endif - CALL SNOWSEAICE (debug_print, & + CALL SNOWSEAICE (debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1973,15 +2016,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5) then ! LAND IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'SOILT snow on land', ktau, i,j,soilt - print *,'SOILT on snow-free land', i,j,soilts - print *,'ts1d,ts1ds',i,j,ts1d,ts1ds + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,' snowfrac = ',snowfrac + print *,' SOILT snow on land', ktau, i,j,soilt + print *,' SOILT on snow-free land', i,j,soilts + print *,' ts1d,ts1ds',i,j,ts1d,ts1ds print *,' SNOW flux',i,j, snflx print *,' Ground flux on snow-covered land',i,j, s print *,' Ground flux on snow-free land', i,j,ss print *,' CSTS, CST', i,j,csts,cst ENDIF + do k=1,nzs soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac @@ -2035,9 +2081,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac IF (debug_print ) THEN - print *,' Ground flux combined', i,j, s - print *,'SOILT combined on land', soilt - print *,'TS combined on land', ts1d + !if (abs(xlat-33.35).lt.0.2 .and. & abs(xlon-272.55).lt.0.2)then + print *,' Ground flux combined', xlat,xlon, s + print *,' SOILT combined on land', soilt + print *,' TS combined on land', ts1d ENDIF else ! SEA ICE @@ -2082,9 +2129,59 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif endif ! snow_mosaic = 1. -! run-total accumulated snow based on snowfall and snowmelt in [m] + !-- 13 jan 2022 + ! update snow fraction after melting (Swenson, S.C. and Lawrence, 2012, + ! JGR, DOI:10.1029/2012MS000165 + ! + !if (snwe > 0.) then + ! if(smelt > 0.) then + !update snow fraction after melting + !n_melt = 200./max(10.,topo_std) + ! snowfrac = max(0.,snowfrac - (acos(min(1.,(2.*(smelt*delt/snwe) - + ! 1.)))/piconst)**10) + !snowfrac = 1. - (acos(min(1.,(2.*(smelt*delt/snwe) - + !1.)))/piconst)**10. + ! if(i==744.and.j==514 .or. i==924.and.j==568)then + !print *,'smr,n_melt,topo_std', smr,n_melt,topo_std + ! print *,'3 - snowfrac end', i,j,ktau,snowfrac,smelt*delt, snwe, + ! piconst + ! endif + ! endif + !else + ! snowfrac = 0. + !endif + ! + !-- The NY07 parameterization gives more realistic snow cover fraction + ! than SL12 + !-- 13 Jan 2022 + !-- update snow fraction after metlting (Niu, G.-Y., and Yang, Z.-L. 2007, + !JGR, + ! DOI:10.1029/2007JD008674) + ! Limit on znt (<0.25) is needed to avoid very small snow fractions in the + ! forested areas with large roughness + + if(isncovr_opt == 1) then + !-- update snow cover after possible melting + snowfrac=min(1.,snhei/(2.*snhei_crit)) + else + !-- isncovr_opt=2 + if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + snowfrac = tanh( snhei/(2.5 * 0.25 *(rhosn/rhonewsn)**1.0)) + else + snowfrac = tanh( snhei/(2.5 *min(0.25,znt) *(rhosn/rhonewsn)**1.0)) + endif + endif + + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains ( Swiss weather model) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + +! run-total accumulated snow based on snowfall and snowmelt in [mm] - snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) + snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio))*1.e3 ELSE !--- no snow @@ -2103,7 +2200,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5) then ! LAND - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & @@ -2130,7 +2227,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia alb=albice RNET = GSWnew + XINET - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -2201,7 +2298,7 @@ END FUNCTION QSN !>\ingroup lsm_ruc_group !> This subroutine calculates energy and moisture budget for vegetated surfaces !! without snow, heat diffusion and Richards eqns in soil. - SUBROUTINE SOIL (debug_print, & + SUBROUTINE SOIL (debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,GSWin,EMISS,RNET, & @@ -2283,7 +2380,7 @@ SUBROUTINE SOIL (debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables REAL, & @@ -2538,7 +2635,7 @@ SUBROUTINE SOIL (debug_print, & !--- water, and DRYCAN is the fraction of vegetated area where !--- transpiration may take place. - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -2571,6 +2668,21 @@ 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 observations 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 @@ -2589,27 +2701,8 @@ SUBROUTINE SOIL (debug_print, & !************************************************************** ! SOILTEMP soilves heat budget and diffusion eqn. in soil !************************************************************** - if(1==2) then - print *,'i,j,iland,isoil ', i,j,iland,isoil - print *,'delt,ktau,conflx,nzs,nddzs,nroot ',delt,ktau,conflx,nzs,nddzs,nroot - print *,'PRCPMS,RAINF ',PRCPMS,RAINF - print *,'PATM,TABS,QVATM,QCATM,EMISS,RNET ',PATM,TABS,QVATM,QCATM,EMISS,RNET - print *,'QKMS,TKMS,PC,rho,vegfrac, lai ',QKMS,TKMS,PC,rho,vegfrac, lai - print *,'thdif ',thdif - print *,'cap ',cap - print *,'drycan,wetcan ',drycan,wetcan - print *,'transum,dew,soilres,alfa ',transum,dew,soilres,alfa - print *,'mavail ',mavail - print *,'dqm,qmin,bclh,zsmain,zshalf,DTDZS',dqm,qmin,bclh,zsmain,zshalf,DTDZS - print *,'xlv,CP,G0_P,cvw,stbolt ',xlv,CP,G0_P,cvw,stbolt - print *,'tso=',tso - print *,'soilt=',soilt - print *,'qvg=',qvg - print *,'qsg=',qsg - print *,'qcg=',qcg - endif ! 1==2 - - CALL SOILTEMP(debug_print, & + + CALL SOILTEMP(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -2625,15 +2718,6 @@ SUBROUTINE SOIL (debug_print, & !--- output variables tso,soilt,qvg,qsg,qcg,x) -if(1==2) then - print *,'after tso=',tso - print *,'after soilt=',soilt - print *,'after qvg=',qvg - print *,'after qsg=',qsg - print *,'after qcg=',qcg - print *,'after x=',x -endif - !************************************************************************ !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW @@ -2841,7 +2925,7 @@ END SUBROUTINE SOIL !! on its surface. it solves heat diffusion inside ice and energy !! budget at the surface of ice. It computes skin temperature and !! temerature inside sea ice. - SUBROUTINE SICE ( debug_print, & + SUBROUTINE SICE ( debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & EMISS,RNET,QKMS,TKMS,rho,myj, & @@ -2865,7 +2949,7 @@ SUBROUTINE SICE ( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables REAL, & @@ -3013,7 +3097,7 @@ SUBROUTINE SICE ( debug_print, & tn,aa1,bb,pp,fkq,r210 ENDIF QGOLD=QSG - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over sea ice QVG=QS1 QSG=QS1 @@ -3109,7 +3193,7 @@ END SUBROUTINE SICE !! solves energy and moisture budgets on the surface of snow, and !! on the interface of snow and soil. It computes skin temperature, !! snow temperature, snow depth and snow melt. - SUBROUTINE SNOWSOIL ( debug_print, & + SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & @@ -3209,7 +3293,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - SNHEI_CRIT,meltfactor + SNHEI_CRIT,meltfactor,xlat,xlon LOGICAL, INTENT(IN ) :: myj @@ -3521,7 +3605,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & SMELT=0. ! DD1=0. - H=1. + H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3537,18 +3621,18 @@ SUBROUTINE SNOWSOIL ( debug_print, & print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst ENDIF -! SNHEI=SNWE*1.e3/RHOSN +!-- Save SNWE from the previous time step SNWEPR=SNWE ! check if all snow can evaporate during DT BETA=1. - EPDT = EPOT * RAS *DELT*UMVEG + EPDT = EPOT * RAS *DELT IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) + BETA=SNWEPR/EPDT SNWE=0. ENDIF - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -3576,7 +3660,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & IF (debug_print ) THEN print *, 'TSO before calling SNOWTEMP: ', tso ENDIF - CALL SNOWTEMP(debug_print, & + CALL SNOWTEMP(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -3798,7 +3882,7 @@ END SUBROUTINE SNOWSOIL !! its surface. It solves energy budget on the snow interface with !! atmosphere and snow interface with ice. It calculates skin !! temperature, snow and ice temperatures, snow depth and snow melt. - SUBROUTINE SNOWSEAICE( debug_print, & + SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & @@ -3831,7 +3915,7 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - meltfactor, snhei_crit + meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj @@ -3935,6 +4019,7 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt + REAL :: keff !----------------------------------------------------------------- XLMELT=3.35E+5 @@ -3942,6 +4027,12 @@ SUBROUTINE SNOWSEAICE( debug_print, & XLVm=XLV+XLMELT ! STBOLT=5.670151E-8 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + !isncond_opt = 2 + keff = 0.265 + !--- SNOW flag -- ISICE ! ILAND=isice @@ -3981,7 +4072,16 @@ SUBROUTINE SNOWSEAICE( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN + + if(isncond_opt == 1) then THDIFSN = 0.265/RHOCSN + else +!07Jun19 - snow thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + THDIFSN = keff/rhocsn + !print *,'1 keff,rhosn,rhocsn,THDIFSN ',i,j,keff,rhosn,rhocsn,THDIFSN + !-- old version THDIFSN = 0.265/RHOCSN + endif RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -4206,14 +4306,17 @@ SUBROUTINE SNOWSEAICE( debug_print, & print *,'TABS,QVATM,TN,QVG=',TABS,QVATM,TN,QVG ENDIF - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over snow QVG=QS1 QSG=QS1 QCG=0. -!--- SOILT - skin temperature +!--- SOILT - skin temperature of snow on ice SOILT=TS1 + if(nmelt==1 .and. snowfrac==1) then + soilt = min(273.15,soilt) + endif IF (debug_print ) THEN print *,' AFTER VILKA-SNOW on SEAICE' @@ -4271,10 +4374,10 @@ SUBROUTINE SNOWSEAICE( debug_print, & !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + !IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + IF(SOILT.GT.273.15.AND.BETA.EQ.1..AND.SNHEI.GT.0.) THEN ! nmelt = 1 -! soiltfrac=273.15 soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) QSG= QSN(soiltfrac,TBQ)/PP @@ -4383,11 +4486,13 @@ SUBROUTINE SNOWSEAICE( debug_print, & !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE ELSE - if(snhei.ne.0.) then + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) ! BETA*EPOT*RAS*DELT*snowfrac)) + else + snwe = 0. endif ENDIF @@ -4415,7 +4520,15 @@ SUBROUTINE SNOWSEAICE( debug_print, & !13mar18 rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + else +!07Jun19 - snow thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + thdifsn = keff/RHOCSN + endif + endif endif @@ -4553,7 +4666,7 @@ END SUBROUTINE SNOWSEAICE !>\ingroup lsm_ruc_group !> This subroutine solves energy budget equation and heat diffusion !! equation. - SUBROUTINE SOILTEMP( debug_print, & + SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & @@ -4623,7 +4736,7 @@ SUBROUTINE SOILTEMP( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon REAL, INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables REAL, & @@ -4778,7 +4891,7 @@ SUBROUTINE SOILTEMP( debug_print, & ! AA1=AA*alfa+CC PP=PATM*1.E3 AA1=AA1/PP - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 @@ -4801,7 +4914,7 @@ SUBROUTINE SOILTEMP( debug_print, & 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN ! if(i.eq.279.and.j.eq.263) then @@ -4876,7 +4989,7 @@ END SUBROUTINE SOILTEMP !>\ingroup lsm_ruc_group !> This subroutine solves energy bugdget equation and heat diffusion !! equation to obtain snow and soil temperatures. - SUBROUTINE SNOWTEMP( debug_print, & + SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & snwe,snwepr,snhei,newsnow,snowfrac, & @@ -4954,7 +5067,7 @@ SUBROUTINE SNOWTEMP( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & - rhonewsn,meltfactor + rhonewsn,meltfactor,xlat,xlon real :: rhonewcsn !--- 3-D Atmospheric variables @@ -5062,13 +5175,19 @@ SUBROUTINE SNOWTEMP( debug_print, & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn,rr - integer :: nmelt, iter + REAL :: RNET,rsmfrac,soiltfrac,hsn,rr,keff + integer :: nmelt, iter !----------------------------------------------------------------- iter = 0 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + !isncond_opt = 1 + keff = 0.265 + do k=1,nzs transp (k)=0. cotso (k)=0. @@ -5082,7 +5201,16 @@ SUBROUTINE SNOWTEMP( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN + if(isncond_opt == 1) then + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + else +!07Jun19 - thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + THDIFSN = keff/rhocsn + !print *,'2 keff,rhosn,rhocsn,THDIFSN ',i,j,keff,rhosn,rhocsn,THDIFSN + endif + RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -5150,8 +5278,8 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5179,9 +5307,9 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -273.15) endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then @@ -5202,8 +5330,8 @@ SUBROUTINE SNOWTEMP( debug_print, & denom = 1. + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) cotsn=cotso(NZS) @@ -5220,7 +5348,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ETT1=0. EPOT=-QKMS*(QVATM-QGOLD) RHCS=CAP(1) - H=1. + H=MAVAIL !1. TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1) CAN=WETCAN+TRANS UMVEG=1.-VEGFRAC @@ -5309,12 +5437,19 @@ SUBROUTINE SNOWTEMP( debug_print, & AA1=AA1/PP BB=BB-SNOH/TDENOM - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + IF (debug_print ) THEN + if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1-', i,rnet,tabs,tn,aa1,bb,pp,ktau,newsnow,snwepr,snwe,snhei,snowfrac,soilt,soilt1,tso,rhosn + print *,'2-', i,tdenom,fkq,vegfrac,can,R210,D10,R21,D9sn,D1sn,R22sn,R7,prcpms + endif + ENDIF + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 IF (debug_print ) THEN - print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1,xlat,xlon ENDIF IF(Q1.LT.QS1) GOTO 100 !--- if no saturation - goto 100 @@ -5328,9 +5463,10 @@ SUBROUTINE SNOWTEMP( debug_print, & GOTO 200 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF IF(Q1.GT.QS1) GOTO 90 @@ -5355,20 +5491,31 @@ SUBROUTINE SNOWTEMP( debug_print, & iter=1 ! goto 2211 endif -endif ! 1==2 IF (debug_print ) THEN if(iter==1) then print *,'SNOW - QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 endif ENDIF +endif ! 1==2 !--- SOILT - skin temperature SOILT=TS1 + if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > 273.15) then + !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, + !-- check if the snow skin temperature is =<273.15K + !-- when a grid cell is fully covered with snow (snowfrac=1) + !-- or with partial snow cover and snow_mosaic=1 (snowfrac=1). + if (debug_print ) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'soilt is too high =',soilt,xlat,xlon + soilt = min(273.15,soilt) + endif + endif + IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso -! endif + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snwe,snwepr,snhei,snowfr,soilt,soilt1,tso',i,j,snwe,snwepr,snhei,snowfrac,soilt,soilt1,tso ENDIF ! Solution for temperature at 7.5 cm depth and snow-soil interface IF(SNHEI.GE.SNTH) THEN @@ -5380,14 +5527,14 @@ SUBROUTINE SNOWTEMP( debug_print, & else !-- 1 layer in snow TSO(1)=rhtso(NZS)+cotso(NZS)*SOILT - SOILT1=TSO(1) + SOILT1=min(273.15,TSO(1)) tsob=tso(1) endif ELSEIF (SNHEI > 0. .and. SNHEI < SNTH) THEN ! blended TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT tso(1)=(tso(2)+(soilt-tso(2))*fso) - SOILT1=TSO(1) + SOILT1=min(273.15,TSO(1)) tsob=TSO(2) ELSE !-- very thin or zero snow. If snow is thin we suppose that @@ -5423,16 +5570,18 @@ SUBROUTINE SNOWTEMP( debug_print, & IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'SOILT,SOILT1,tso,TSOB,QSG',i,j,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Final SOILT,SOILT1,tso,TSOB,QSG',xlat,xlon,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + print *,'SNWEPR-BETA*EPOT*RAS*DELT',SNWEPR-BETA*EPOT*RAS*DELT,beta,snwepr,epot ENDIF if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN -! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.AND.SNHEI.GT.0.) THEN +! if all snow can evaporate (beta<1), then there is nothing to melt + IF(SOILT.GT.273.15.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN + !-- snow sublimation and melting nmelt = 1 soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) @@ -5444,6 +5593,7 @@ SUBROUTINE SNOWTEMP( debug_print, & EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS + IF (Q1.LE.0..or.iter==1) THEN ! --- condensation DEW=-EPOT @@ -5486,7 +5636,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ENDIF ! - X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & + X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & XLVM*R210*(QVG-QGOLD) IF (debug_print ) THEN print *,'SNOWTEMP storage ',i,j,x @@ -5502,69 +5652,110 @@ SUBROUTINE SNOWTEMP( debug_print, & !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 IF (debug_print ) THEN - print *,'1- SMELT',i,j,smelt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1- SMELT',smelt,snoh,xlat,xlon ENDIF - SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - IF (debug_print ) THEN - print *,'2- SMELT',i,j,smelt - ENDIF - SMELT=AMAX1(0.,SMELT) + + IF(EPOT.gt.0. .and. SNWEPR.LE.EPOT*RAS*DELT) THEN +!-- all snow can evaporate + BETA=SNWEPR/(EPOT*RAS*DELT) + SMELT=AMAX1(0.,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) + SNWE=0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'2- SMELT',xlat,xlon,snwe,smelt,rhonewsn,xlat,xlon + ENDIF + goto 88 + ENDIF !18apr08 - Egglston limit -! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) + !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow + !-- (rhosn > 350.) with very warm surface temperatures (>10C) + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-273.15))) -! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP - IF (debug_print ) THEN - print *,'3- SMELT',i,j,smelt - ENDIF +! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon + ENDIF + endif ! rr - potential melting rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) - SMELT=min(SMELT,rr) - IF (debug_print ) THEN - print *,'4- SMELT i,j,smelt,rr',i,j,smelt,rr - ENDIF + if(smelt > rr) then + SMELT = min(SMELT,rr) + SNWE = 0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'4- SMELT i,j,smelt,rr',xlat,xlon,smelt,rr + ENDIF + endif + 88 continue SNOHGNEW=SMELT*XLMELT*1.E3 SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW - IF (debug_print ) THEN - print *,'SNOH,SNODIF',SNOH,SNODIF - ENDIF + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'SNOH,SNODIF',SNOH,SNODIF + print *,' xlat, xlon', xlat, xlon + ENDIF + IF( smelt > 0.) then !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01) then + if(snhei > 0.01 .and. rhosn < 350.) then rsm=min(snwe,rsmfrac*smelt*delt) else -! do not keep melted water if snow depth is less that 1 cm + ! do not keep melted water if snow depth is less that 1 cm + ! or if snow is dense rsm=0. endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=max(0.,SMELT-rsm/delt) - IF (debug_print ) THEN - print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + if(rsm > 0.) then + SMELT=max(0.,SMELT-rsm/delt) + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac - ENDIF + print *,' xlat, xlon', xlat, xlon + ENDIF + endif ! rsm + + ENDIF ! smelt > 0 !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & -! (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & + if(snwe > 0.) then + SNWE = AMAX1(0.,(SNWEPR- & + (SMELT+BETA*EPOT*RAS)*DELT & ) ) -!--- If there is no snow melting then just evaporation -!--- or condensation cxhanges SNWE + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' Snow is melting and sublimating, snwe', xlat, xlon, SNWE + endif + else + !-- all snow is sublimated or melted + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' all snwe is sublimated or melted', xlat, xlon, SNWE + endif + endif ELSE - if(snhei.ne.0.) then +!--- If there is no snow melting then just evaporation +!--- or condensation changes SNWE + !-- no melting, only sublimation + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) + else + !-- all snow is sublibated + snwe = 0. endif ENDIF + !18apr08 - if snow melt occurred then go into iteration for energy budget ! solution if(nmelt.eq.1) goto 212 ! second interation @@ -5587,7 +5778,14 @@ SUBROUTINE SNOWTEMP( debug_print, & ! rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + else +!07Jun19 - snow thermal conductivity from the paper by Sturm et al., 1997 - K_eff + keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + thdifsn = keff / rhocsn + endif endif endif @@ -5612,28 +5810,41 @@ SUBROUTINE SNOWTEMP( debug_print, & !-- is above freezing snow can melt from the bottom. The following !-- piece of code will check if bottom melting is possible. - IF(TSO(1).GT.273.15 .and. snhei > 0.) THEN + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snhei,snwe,rhosn,snowfr',snhei,snwe,rhosn,snowfrac,xlat,xlon + endif + + IF(TSO(1).GT.273.15 .and. snhei > 0. .and. beta == 1.) THEN + !-- melting in the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn - IF (debug_print ) THEN - print*,'2 layer snow - snhei,hsn',snhei,hsn - ENDIF + IF (debug_print ) THEN + print*,'2 layer snow - snhei,hsn',snhei,hsn + ENDIF else - IF (debug_print ) THEN - print*,'1 layer snow or blended - snhei',snhei - ENDIF + IF (debug_print ) THEN + print*,'1 layer snow or blended - snhei',snhei + ENDIF hsn = snhei endif soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) - SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & + SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT - SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. - SMELTG=SNOHG/XLMELT*1.E-3 + SNOHG=AMAX1(0.,SNOHG) + SNODIF=0. + SMELTG=SNOHG/XLMELT*1.E-3 + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' SMELTG =',smeltg,xlat,xlon + endif ! Egglston - empirical limit on snow melt from the bottom of snow pack + !9jun22-- exclude summer hail from limiting snow melt + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELTG=AMIN1(SMELTG, 5.8e-9) + endif ! rr - potential melting rr=SNWE/delt @@ -5642,41 +5853,39 @@ SUBROUTINE SNOWTEMP( debug_print, & SNOHGNEW=SMELTG*XLMELT*1.e3 SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then - print *,'TSO(1),soiltfrac,smeltg,SNODIF',TSO(1),soiltfrac,smeltg,SNODIF + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,' xlat, xlon', xlat, xlon ENDIF -! snwe=max(0.,snwe-smeltg*delt*snowfrac) snwe=max(0.,snwe-smeltg*delt) SNHEI=SNWE *1.E3 / RHOSN if(snhei > 0.) TSO(1) = soiltfrac IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'Melt from the bottom snwe,snhei',snwe,snhei + print *,' xlat, xlon', xlat, xlon + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,'Melt from the bottom snwe,snhei,snoh',snwe,snhei,snoh + print *,' Final TSO ',tso if (snhei==0.) & print *,'Snow is all melted on the warm ground' ENDIF - ENDIF - IF (debug_print ) THEN - print *,'SNHEI,SNOH',i,j,SNHEI,SNOH - ENDIF -! & + ENDIF ! melt on snow/soil interface + snweprint=snwe snheiprint=snweprint*1.E3 / RHOSN - IF (debug_print ) THEN -print *, 'snweprint : ',snweprint -print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB - ENDIF - - X= (R21+D9SN*R22SN)*(soilt-TN) + & + X= (R21+D9SN*R22SN)*(soilt-TN) + & XLVM*R210*(QSG-QGOLD) IF (debug_print ) THEN - print *,'SNOWTEMP storage ',i,j,x + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'end SNOWTEMP storage ',xlat,xlon,x print *,'R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', & R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim + print *,'snwe, snhei ',snwe,snhei ENDIF X=X & @@ -5691,14 +5900,14 @@ SUBROUTINE SNOWTEMP( debug_print, & IF(SNHEI.GT.0.) THEN if(ilnb.gt.1) then - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15) else - tsnav=0.5*(soilt+tso(1)) - 273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) - 273.15) endif ELSE - tsnav= soilt - 273.15 + tsnav= min(0.,soilt - 273.15) ENDIF !------------------------------------------------------------------------ @@ -5904,7 +6113,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ! TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - TOTLIQ=PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT + TOTLIQ=PRCP-DRIP/DELT-(1.-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT @@ -6497,13 +6706,13 @@ END SUBROUTINE TRANSF !> This subroutine finds the solution of energy budget at the surface !! from the pre-computed table of saturated water vapor mixing ratio !! and estimated surface temperature. - SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) + SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !-------------------------------------------------------------- !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- REAL, DIMENSION(1:5001), INTENT(IN ) :: TT - REAL, INTENT(IN ) :: TN,D1,D2,PP + REAL, INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil REAL, INTENT(OUT ) :: QS, TS @@ -6526,12 +6735,12 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) IF(I1.NE.I) GOTO 10 TS=T1-.05*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP -! print *,'in VILKA - TS,QS',ts,qs GOTO 20 ! 1 PRINT *,'Crash in surface energy budget - STOP' 1 PRINT *,' AVOST IN VILKA Table index= ',I ! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn + print *,'AVOST point at xlat/xlon=',xlat,xlon ! CALL wrf_error_fatal (' Crash in surface energy budget ' ) 20 CONTINUE !----------------------------------------------------------------------- @@ -7284,6 +7493,8 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) READ (19,*) READ (19,*)BARE READ (19,*) + READ (19,*)GLACIER + READ (19,*) READ (19,*)NATURAL READ (19,*) READ (19,*)CROP diff --git a/physics/moninshoc.f b/physics/moninshoc.f index eb6cbd0028..7d27503b99 100644 --- a/physics/moninshoc.f +++ b/physics/moninshoc.f @@ -4,9 +4,6 @@ !> This module contains the CCPP-compliant SHOC scheme. module moninshoc - use mfpbl_mod - use tridi_mod - contains subroutine moninshoc_init (do_shoc, errmsg, errflg) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 08a28f2bd5..3ac09c5b63 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -82,12 +82,6 @@ subroutine mynnedmf_wrapper_init ( & return end if - if (lheatstrg) then - errmsg = 'Logic error: lheatstrg not implemented for MYNN PBL' - errflg = 1 - return - end if - end subroutine mynnedmf_wrapper_init !>\defgroup gp_mynnedmf MYNN-EDMF PBL and Shallow Convection Module @@ -158,14 +152,15 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, rrfs_smoke, fire_turb, nchem, ndvel, & + & rrfs_sd, chem3d, frp, mix_chem, enh_mix, & + & nchem, ndvel, vdep, smoke_dbg, & & imp_physics_nssl, nssl_ccn_on, & & ltaerosol, mraerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: use machine, only: kind_phys use bl_mynn_common, only: cp, r_d, grav, g_inv, zero, & - xlv, xlvcp, xlscp + xlv, xlvcp, xlscp, p608 use module_bl_mynn, only: mynn_bl_driver !------------------------------------------------------------------- @@ -182,6 +177,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !smoke/chem integer, intent(in) :: nchem, ndvel integer, parameter :: kdvel=1 + logical, intent(in) :: smoke_dbg ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & @@ -206,7 +202,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & imp_physics_thompson, imp_physics_gfdl, & & imp_physics_nssl, & & spp_pbl - real, intent(in) :: & + real(kind=kind_phys), intent(in) :: & & bl_mynn_closure !TENDENCY DIAGNOSTICS @@ -274,7 +270,7 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), dimension(:), intent(in) :: xmu real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw ! spp_wts_pbl only allocated if spp_pbl == 1 - real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + real(kind=kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl !LOCAL real(kind=kind_phys), dimension(im,levs) :: & @@ -286,11 +282,11 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - real(kind_phys), dimension(:), intent(inout) :: frp - logical, intent(in) :: mix_chem, fire_turb, rrfs_smoke + real(kind=kind_phys), dimension(:), intent(inout) :: frp + logical, intent(in) :: mix_chem, enh_mix, rrfs_sd real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind=kind_phys), dimension(:,: ), intent(inout) :: vdep real(kind=kind_phys), dimension(im) :: emis_ant_no - real(kind=kind_phys), dimension(im,ndvel) :: vdep !MYNN-2D real(kind=kind_phys), dimension(:), intent(in) :: & @@ -357,7 +353,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - vdep = 0. ! hli for chem dry deposition, 0 temporarily ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) @@ -594,11 +589,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im ! 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)) + rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)*(1.+p608*max(sqv(i,k),1e-8))) w(i,k) = -omega(i,k)/(rho(i,k)*grav) enddo enddo @@ -616,6 +607,11 @@ SUBROUTINE mynnedmf_wrapper_run( & ch(i)=0.0 hfx(i)=hflx(i)*rho(i,1)*cp qfx(i)=qflx(i)*rho(i,1) + !filter bad incoming fluxes + if (hfx(i) > 1200.)hfx(i) = 1200. + if (hfx(i) < -500.)hfx(i) = -500. + if (qfx(i) > .0005)qfx(i) = 0.0005 + if (qfx(i) < -.0002)qfx(i) = -0.0002 dtsfc1(i) = hfx(i) dqsfc1(i) = qfx(i)*XLV @@ -742,10 +738,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & sh3d=Sh3d,sm3d=Sm3d, & !chem/smoke & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & - & Chem3d=chem3d,Vdep=vdep, & + & Chem3d=chem3d,Vdep=vdep,smoke_dbg=smoke_dbg, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & - & mix_chem=mix_chem,fire_turb=fire_turb, & - & rrfs_smoke=rrfs_smoke, & + & mix_chem=mix_chem,enh_mix=enh_mix, & + & rrfs_sd=rrfs_sd, & !----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output @@ -1076,9 +1072,9 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & 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(kind=kind_phys), intent(in) :: delt + real(kind=kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind=kind_phys), 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 diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index a44a13f1ba..4a9cd18f0c 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1359,9 +1359,9 @@ type = real kind = kind_phys intent = inout -[rrfs_smoke] +[rrfs_sd] standard_name = do_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) + long_name = flag controlling rrfs_sd collection (default off) units = flag dimensions = () type = logical @@ -1373,7 +1373,7 @@ dimensions = () type = logical intent = in -[fire_turb] +[enh_mix] standard_name = do_planetary_boundary_layer_fire_enhancement long_name = flag for rrfs smoke mynn enh vermix units = flag @@ -1394,6 +1394,21 @@ dimensions = () type = integer intent = in +[vdep] + standard_name = dry_deposition_velocity_mynn_pbl_transport + long_name = dry deposition velocity by mynn pbl transport + units = m s-1 + dimensions = (horizontal_loop_extent,2) + type = real + kind = kind_phys + intent = in +[smoke_dbg] + standard_name = do_smoke_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + intent = in [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics diff --git a/physics/mynnsfc_wrapper.F90 b/physics/mynnsfc_wrapper.F90 index 4be912ab74..925cd33cf8 100644 --- a/physics/mynnsfc_wrapper.F90 +++ b/physics/mynnsfc_wrapper.F90 @@ -301,6 +301,7 @@ SUBROUTINE mynnsfc_wrapper_run( & z0pert=z0pert,ztpert=ztpert, & !intent(in) redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & + flag_restart=flag_restart, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) tsurf_wat=tsurf_wat, tsurf_lnd=tsurf_lnd, tsurf_ice=tsurf_ice, & !intent(in) diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index 1e05122c41..4708fdc022 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -32,6 +32,7 @@ module namelist_soilveg_ruc REAL CFACTR_DATA REAL RSMAX_DATA INTEGER BARE + INTEGER GLACIER INTEGER NATURAL INTEGER CROP INTEGER URBAN diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 04609382dc..81899ccf9d 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -285,8 +285,7 @@ module rrtmg_lw use mersenne_twister, only : random_setseed, random_number, & & random_stat use machine, only : kind_phys, & - & im => kind_io4, rb => kind_phys, & - & kind_dbl_prec + & im => kind_io4, rb => kind_phys use module_radlw_parameters ! @@ -1893,10 +1892,9 @@ subroutine mcica_subcol & logical, dimension(ngptlw,nlay), intent(out) :: lcloudy ! --- locals: - real (kind=kind_phys) :: cdfunc(ngptlw,nlay), & - & tem1, fac_lcf(nlay), & + real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), & + & rand2d(nlay*ngptlw), tem1, fac_lcf(nlay), & & cdfun2(ngptlw,nlay) - real (kind=kind_dbl_prec) rand2d(nlay*ngptlw), rand1d(ngptlw) type (random_stat) :: stat ! for thread safe random generator diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 9286c45cb8..df1a368c51 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index ae2f21e185..914ca6cdf5 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -310,7 +310,7 @@ module rrtmg_sw use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use machine, only : rb => kind_phys, im => kind_io4, & - & kind_phys, kind_dbl_prec + & kind_phys use module_radsw_parameters use mersenne_twister, only : random_setseed, random_number, & @@ -1545,10 +1545,6 @@ subroutine rswinit & tfn = float(i) / float(NTBMX-i) tau = bpade * tfn exp_tbl(i) = exp( -tau ) -#ifdef SINGLE_PREC - ! from WRF version, prevents zero at single prec - if (exp_tbl(i) .le. expeps) exp_tbl(i) = expeps -#endif enddo return @@ -2014,9 +2010,8 @@ subroutine mcica_subcol & ! --- locals: real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & - & fac_lcf(nlay), & + & rand2d(nlay*ngptsw), rand1d(ngptsw), fac_lcf(nlay), & & cdfun2(nlay,ngptsw) - real (kind=kind_dbl_prec) :: rand2d(nlay*ngptsw), rand1d(ngptsw) ! must be default real kind to match mersenne twister code type (random_stat) :: stat ! for thread safe random generator diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 506e2edf07..70bc136f3d 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 0dc54f5eca..cec1e8e12d 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 0dc54f5ecaeb1e1e342efd1e02d0bcd41737bde2 +Subproject commit cec1e8e12d969c3c8c76574dbe4f40b366419cc7 diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 2a3c256a9d..f9c13a0340 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -75,14 +75,15 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & tmf,qmicro,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & & t0c,delt,ntk,ntr,delp, & - & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & - & hwrf_samfdeep,progsigma,cldwrk,rn,kbot,ktop,kcnv, & - & islimsk,garea,dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & + & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav,hwrf_samfdeep, & + & cldwrk,rn,kbot,ktop,kcnv,islimsk,garea, & + & dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & - & do_ca, ca_closure, ca_entr, ca_trigger, nthresh,ca_deep, & - & rainevap,sigmain, sigmaout, errmsg,errflg) + & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & + & rainevap, & + & errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -97,14 +98,10 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) real(kind=kind_phys), dimension(:), intent(in) :: fscav - logical, intent(in) :: first_time_step,restart,hwrf_samfdeep, & - & progsigma + logical, intent(in) :: hwrf_samfdeep real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) - real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & - & tmf(:,:),q(:,:), prevsq(:,:) real(kind=kind_phys), intent(out) :: rainevap(:) - real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger integer, intent(inout) :: kcnv(:) @@ -305,7 +302,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & errmsg = '' errflg = 0 - gravinv = 1./grav elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -374,7 +370,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & vshear(i) = 0. advfac(i) = 0. rainevap(i) = 0. - omegac(i)=0. gdx(i) = sqrt(garea(i)) enddo @@ -580,17 +575,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & endif enddo enddo - - do k = 1, km - do i = 1, im - dbyo1(i,k)=0. - zdqca(i,k)=0. - qlks(i,k)=0. - omega_u(i,k)=0. - zeta(i,k)=1.0 - enddo - enddo - ! ! initialize tracer variables ! @@ -923,6 +907,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo if(totflg) return !! +! +!Lisa: at this point only trigger criteria is set ! turbulent entrainment rate assumed to be proportional ! to subcloud mean TKE @@ -1515,7 +1501,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk endif ! ! compute buoyancy and drag for updraft velocity @@ -1588,7 +1573,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & dz1 = zo(i,k+1) - zo(i,k) ! aa1(i) = aa1(i) + buo(i,k) * dz1 * eta(i,k) aa1(i) = aa1(i) + buo(i,k) * dz1 - dbyo1(i,k) = hcko(i,k) - heso(i,k) endif endif enddo @@ -1690,7 +1674,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk endif endif endif @@ -1732,20 +1715,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & endif enddo enddo - - if(progsigma)then - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k > kbcon1(i) .and. k < ktcon(i)) then - rho = po(i,k)*100. / (rd * to(i,k)) - omega_u(i,k)=-1.0*sqrt(wu2(i,k))*rho*grav - omega_u(i,k)=MAX(omega_u(i,k),-80.) - endif - endif - enddo - enddo - endif ! ! compute updraft velocity average over the whole cumulus ! @@ -1860,28 +1829,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) endif endif enddo endif c - -c store term needed for "termC" in prognostic area fraction closure - if(progsigma)then - do k = 2, km1 - do i = 1, im - dp = 1000. * del(i,k) - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - endif - ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then ccccc print *, ' aa1(i) before dwndrft =', aa1(i) ccccc endif @@ -2464,7 +2416,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & c c------- final changed variable per unit mass flux c -!> - If grid size is less than a threshold value (dxcrtas: currently 8km if progsigma is not used and 30km if progsigma is used), the quasi-equilibrium assumption of Arakawa-Schubert is not used any longer. +!> - If grid size is less than a threshold value (dxcrtas: currently 8km), the quasi-equilibrium assumption of Arakawa-Schubert is not used any longer. ! if(progsigma)then dxcrtas=30.e3 @@ -2481,7 +2433,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & asqecflg(i) = .false. endif enddo - ! !> - If grid size is larger than the threshold value (i.e., asqecflg=.true.), the quasi-equilibrium assumption is used to obtain the cloud base mass flux. To begin with, calculate the change in the temperature and moisture profiles per unit cloud base mass flux. do k = 1, km @@ -2894,16 +2845,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. - do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - if(progsigma)then - xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) - else - xmb(i) = advfac(i)*betaw*rho*wc(i) - endif + xmb(i) = advfac(i)*betaw*rho*wc(i) endif enddo !> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : @@ -2972,11 +2918,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i = 1, im if(cnvflg(i)) then if (gdx(i) < dxcrtuf) then - if(progsigma)then - scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) - else - scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) - endif + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) else scaldfunc(i) = 1.0 @@ -2986,6 +2928,16 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & endif enddo ! + if (do_ca .and. ca_closure)then + do i = 1, im + if(cnvflg(i)) then + if (ca_deep(i) > nthresh) then + xmb(i) = xmb(i)*1.25 + endif + endif + enddo + endif + !> - Transport aerosols if present ! ! if (do_aerosols) diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 3f28035b63..baf01fb8ea 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfdeepcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 + dependencies = funcphys.f90,machine.F,samfaerosols.F ######################################################################## [ccpp-arg-table] @@ -55,36 +55,6 @@ dimensions = () type = integer intent = in -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in -[restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in -[tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qmicro] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics - long_name = moisture tendency due to microphysics - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [itc] standard_name = index_of_first_chemical_tracer_for_convection long_name = index of first chemical tracer transported/scavenged by convection @@ -249,22 +219,6 @@ type = real kind = kind_phys intent = inout -[prevsq] - standard_name = specific_humidity_on_previous_timestep - long_name = specific_humidity_on_previous_timestep - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[q] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [q1] standard_name = specific_humidity_of_new_state long_name = updated vapor specific humidity @@ -312,13 +266,6 @@ dimensions = () type = logical intent = in -[progsigma] - standard_name = do_prognostic_updraft_area_fraction - long_name = flag for prognostic sigma in cumuls scheme - units = flag - dimensions = () - type = logical - intent = in [cldwrk] standard_name = cloud_work_function long_name = cloud work function @@ -434,22 +381,6 @@ type = real kind = kind_phys intent = inout -[sigmain] - standard_name = prognostic_updraft_area_fraction_in_convection - long_name = convective updraft area fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sigmaout] - standard_name = updraft_area_fraction_updated_by_physics - long_name = convective updraft area fraction updated by physics - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out [qlcn] standard_name = mass_fraction_of_convective_cloud_liquid_water long_name = mass fraction of convective cloud liquid water diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 645024536e..613675f493 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -50,13 +50,11 @@ end subroutine samfshalcnv_init !! \section det_samfshalcnv GFS samfshalcnv Detailed Algorithm subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eps,epsm1,fv,grav,hvap,rd,rv, & - & t0c,delt,ntk,ntr,delp,first_time_step,restart, & - & tmf,qmicro,progsigma, & - & prslp,psp,phil,qtr,prevsq,q,q1,t1,u1,v1,fscav, & + & t0c,delt,ntk,ntr,delp, & + & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & - & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, & - & sigmain,sigmaout,errmsg,errflg) + & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -69,10 +67,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eps, epsm1, fv, grav, hvap, rd, rv, t0c real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & - & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & - & qmicro(:,:),tmf(:,:),prevsq(:,:),q(:,:) - - real(kind=kind_phys), intent(in) :: sigmain(:,:) + & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) ! real(kind=kind_phys), dimension(:), intent(in) :: fscav integer, intent(inout) :: kcnv(:) @@ -82,12 +77,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! integer, intent(out) :: kbot(:), ktop(:) real(kind=kind_phys), intent(out) :: rn(:), & - & cnvw(:,:), cnvc(:,:), ud_mf(:,:), dt_mf(:,:), sigmaout(:,:) + & cnvw(:,:), cnvc(:,:), ud_mf(:,:), dt_mf(:,:) ! real(kind=kind_phys), intent(in) :: clam, c0s, c1, & & asolfac, evef, pgcon - logical, intent(in) :: hwrf_samfshal,first_time_step, & - & restart,progsigma + logical, intent(in) :: hwrf_samfshal character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! @@ -190,8 +184,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrtc0=9.e3) parameter(h1=0.33333333) -! progsigma - parameter(dxcrtas=30.e3) c local variables and arrays real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), & uo(im,km), vo(im,km), qeso(im,km), @@ -246,8 +238,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & errmsg = '' errflg = 0 - gravinv = 1./grav - elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -342,7 +332,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo endif !! - !> - Return to the calling routine if deep convection is present or the surface buoyancy flux is negative. totflg = .true. do i=1,im @@ -515,20 +504,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif enddo enddo - - do i = 1,im - omegac(i)=0. - enddo - - do k = 1, km - do i = 1, im - dbyo1(i,k)=0. - zdqca(i,k)=0. - qlks(i,k)=0. - omega_u(i,k)=0. - zeta(i,k)=1.0 - enddo - enddo ! ! initialize tracer variables ! @@ -1270,7 +1245,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k)= qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk endif ! ! compute buoyancy and drag for updraft velocity @@ -1338,7 +1312,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(k >= kbcon(i) .and. k < ktcon(i)) then dz1 = zo(i,k+1) - zo(i,k) aa1(i) = aa1(i) + buo(i,k) * dz1 - dbyo1(i,k) = hcko(i,k) - heso(i,k) endif endif enddo @@ -1435,7 +1408,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k) = qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk endif endif endif @@ -1478,20 +1450,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo enddo ! - if(progsigma)then - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k > kbcon1(i) .and. k < ktcon(i)) then - rho = po(i,k)*100. / (rd * to(i,k)) - omega_u(i,k)=-1.0*sqrt(wu2(i,k))*rho*grav - omega_u(i,k)=MAX(omega_u(i,k),-80.) - endif - endif - enddo - enddo - endif - ! compute updraft velocity averaged over the whole cumulus ! !> - Calculate the mean updraft velocity within the cloud (wc). @@ -1601,24 +1559,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) endif endif enddo endif c - - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - c--- compute precipitation efficiency in terms of windshear c !! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : @@ -1944,16 +1889,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. - do i= 1, im if(cnvflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - if(progsigma .and. gdx(i) < dxcrtas)then - xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) - else - xmb(i) = advfac(i)*betaw*rho*wc(i) - endif + xmb(i) = advfac(i)*betaw*rho*wc(i) endif enddo ! @@ -1973,12 +1913,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if(cnvflg(i)) then if (gdx(i) < dxcrt) then - if(progsigma)then - scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) - else - scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) - endif - scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) else scaldfunc(i) = 1.0 endif diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index 8c9735c329..d768d44510 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfshalcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 + dependencies = funcphys.f90,machine.F,samfaerosols.F ######################################################################## [ccpp-arg-table] @@ -55,36 +55,6 @@ dimensions = () type = integer intent = in -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in -[restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in -[tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qmicro] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics - long_name = moisture tendency due to microphysics - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [itc] standard_name = index_of_first_chemical_tracer_for_convection long_name = index of first chemical tracer transported/scavenged by convection @@ -249,22 +219,6 @@ type = real kind = kind_phys intent = inout -[prevsq] - standard_name = specific_humidity_on_previous_timestep - long_name = specific_humidity_on_previous_timestep - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[q] - standard_name = specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [q1] standard_name = specific_humidity_of_new_state long_name = updated vapor specific humidity @@ -459,29 +413,6 @@ dimensions = () type = logical intent = in -[progsigma] - standard_name = do_prognostic_updraft_area_fraction - long_name = flag for prognostic sigma in cumulus scheme - units = flag - dimensions = () - type = logical - intent = in -[sigmain] - standard_name = prognostic_updraft_area_fraction_in_convection - long_name = convective updraft area fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sigmaout] - standard_name = updraft_area_fraction_updated_by_physics - long_name = convective updraft area fraction updated by physics - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index 79f7bbea1e..e5c8c61a7c 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -4,9 +4,7 @@ !! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). module satmedmfvdif - use tridi_mod - use mfscu_mod - use mfpblt_mod + contains !> \section arg_table_satmedmfvdif_init Argument Table diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 08876f8f04..54d00bc52a 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -4,9 +4,7 @@ !! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). module satmedmfvdifq - use mfpbltq_mod - use tridi_mod - use mfscuq_mod + contains !> \defgroup module_satmedmfvdifq GFS TKE-EDMF PBL Module @@ -98,7 +96,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & integer, intent(in) :: tc_pbl integer, intent(in) :: kinver(:) integer, intent(out) :: kpbl(:) - logical, intent(in) :: gen_tend,ldiag3d,progsigma + logical, intent(in) :: gen_tend,ldiag3d ! real(kind=kind_phys), intent(in) :: grav,rd,cp,rv,hvap,hfus,fv, & & eps,epsm1 @@ -106,7 +104,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & - & tdt(:,:), rtg(:,:,:), tmf(:,:) + & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & & t1(:,:), q1(:,:,:), & @@ -331,14 +329,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & zm(i,k) = zi(i,k+1) enddo enddo -!> - Initialize variables needed for prognostic cumulus closure - if(progsigma)then - do k=1,km - do i=1,im - tmf(i,k) = 0. - enddo - enddo - endif !> - Compute horizontal grid size (\p gdx) do i=1,im gdx(i) = sqrt(garea(i)) @@ -2205,15 +2195,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo - - if(progsigma)then - do k = 1,km - do i = 1,im - tmf(i,k)=(f2(i,k)-q1(i,k,1))*rdt - enddo - enddo - endif - do i = 1,im dtsfc(i) = rho_a(i) * cp * heat(i) dqsfc(i) = rho_a(i) * hvap * evap(i) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index d9ab8c8593..d0b11656a0 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -62,13 +62,6 @@ dimensions = () type = integer intent = in -[progsigma] - standard_name = do_prognostic_updraft_area_fraction - long_name = flag for prognostic sigma in cumuls scheme - units = flag - dimensions = () - type = logical - intent = in [ntrac] standard_name = number_of_vertical_diffusion_tracers long_name = number of tracers to diffuse vertically @@ -208,14 +201,6 @@ type = real kind = kind_phys intent = inout -[tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [u1] standard_name = x_wind long_name = x component of layer wind diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index c55c3b72af..4d5151bb7d 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -150,11 +150,14 @@ 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 @@ -180,6 +183,8 @@ 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 @@ -190,23 +195,13 @@ 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 diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index cac4fd1e79..a6d7aa08b9 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -29,7 +29,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -195,9 +195,10 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & 0., 0., 0., 0., 0., 0./) natural = 10 - bare = 16 crop = 12 urban = 13 + glacier = 15 + bare = 16 endif ! end if veg table @@ -337,7 +338,8 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) - SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & + SATPSI =(/0.121, 0.150, 0.218, 0.786, 0.786, 0.478, & + !SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & & 0.299, 0.356, 0.630, 0.153, 0.490, 0.405, & & 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, & & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 045ad75b0c..a49528bc9d 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -10,30 +10,44 @@ module sfc_diag !! \section arg_table_sfc_diag_run Argument Table !! \htmlinclude sfc_diag_run.html !! - subroutine sfc_diag_run & - & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & - & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & - & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine sfc_diag_run (im,xlat_d,xlon_d, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & + & wet,shflx,chs2,cqs2,cdq,wind, & + & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & + & tskin,qsurf,thsfc_loc,diag_flux,diag_log, & + & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! use machine , only : kind_phys use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im + integer, intent(in) :: im, lsm, lsm_ruc logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. - real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 - real(kind=kind_phys), dimension(:), intent(in) :: & - & ps, u1, v1, t1, q1, tskin, & - & qsurf, prslki, evap, fm, fh, fm10, fh2 + logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics + logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions + real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), dimension(:), intent( in) :: & + & zf, ps, u1, v1, t1, q1, tskin, wet, & + & qsurf, prslki, evap, fm, fh, fm10, fh2, & + & shflx, chs2, cqs2, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & - & f10m, u10m, v10m, t2m, q2m + & f10m, u10m, v10m, t2m, q2m, dpt2m character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! ! locals ! + logical :: debug_print real(kind=kind_phys), parameter :: qmin=1.0e-8 + real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho + real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 + real(kind=kind_phys) :: t2_alt, q2_alt + real(kind=kind_phys) :: thcon, cqs, chs + real(kind=kind_phys) :: testptlat, testptlon integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk @@ -44,6 +58,12 @@ subroutine sfc_diag_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + + !-- + testptlat = 35.3 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 273.0 !284.50 !286.75 !280.6 !164.0 !283.0 + !-- + debug_print = .false. ! ! estimate sigma ** k at 2 m ! @@ -53,6 +73,8 @@ subroutine sfc_diag_run & ! ps is in pascals ! !! + + do i = 1, im f10m(i) = fm10(i) / fm(i) ! f10m(i) = min(f10m(i),1.) @@ -64,23 +86,134 @@ subroutine sfc_diag_run & ! t2m(i) = t2m(i) * sig2k wrk = 1.0 - fhi + thcon = (1.e5/ps(i))**rocp + !-- make sure 1st level q is not higher than saturated value + qss = fpvs(t1(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q1c = min(q1(i),qss) ! lev 1 spec. humidity - if(thsfc_loc) then ! Use local potential temperature - t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif + qv1 = q1c / (1. - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio + chs = cdq(i) * wind(i) + cqs = chs + qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1(i))*fhi - endif + if(.not. diag_flux) then + !-- original method + if(lsm /= lsm_ruc) then + if(thsfc_loc) then ! Use local potential temperature + t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1c)*fhi + endif + else + !-- RUC lsm + !if(chs.lt.1.E-5) then + !-- under very stable conditions use first level temperature + ! t2m(i) = t1(i) + !else + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + !endif + + !if(cqs.lt.1.E-5) then + ! q2m(i)=max(qmin,q1c) ! spec. humidity + !else + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + !endif + endif ! RUC lsm + + else + !-- flux method + !if(chs2(i).lt.1.E-5) then + !-- under very stable conditions use first level temperature + ! t2m(i) = t1(i) + !else + th2m = tskin(i)*thcon - shflx(i)/chs2(i) + t2m(i) = th2m/thcon + !endif + + !if(cqs2(i).lt.1.E-5) then + !-- under very stable conditions use first level for 2-m mixing ratio + ! q2m(i)=max(qmin,q1c) ! spec. humidity + !else + x2m = max(qmin,qsfcprox - evap(i)/cqs2(i)) ! mix. ratio + q2m(i) = x2m/(1. + x2m) ! spec. humidity + !endif + + if(diag_log) then + !-- Alternative logarithmic diagnostics: + dT = t1(i) - tskin(i) + dQ = qv1 - qsfcmr + dz1= zf(i) ! level of atm. forcing + IF (dT > 0.) THEN + ff = MIN(MAX(1.-dT/10.,0.01), 1.0) + !for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + T2_alt = tskin(i) + fac * dT + ELSE + !no alternatives (yet) for unstable conditions + T2_alt = t2m(i) + ENDIF + + IF (dQ > 0.) THEN + ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) + !-- for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + Q2_alt = qsfcmr + fac * dQ ! mix. ratio + Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity + ELSE + !no alternatives (yet) for unstable conditions + Q2_alt = q2m(i) + ENDIF + !-- Note: use of alternative diagnostics will make + ! it cooler and drier with stable stratification + t2m(i) = T2_alt + q2m(i) = Q2_alt + endif ! log method for stable regime + endif ! flux method + + !-- check that T2m values lie in the range between tskin and t1 + x2m = max(min(tskin(i),t1(i)) , t2m(i)) + t2m(i) = min(max(tskin(i),t1(i)) , x2m) + !-- check that Q2m values lie in the range between qsurf and q1 + x2m = max(min(qsurf(i),q1c) , q2m(i)) + q2m(i) = min(max(qsurf(i),q1c) , x2m) + + !-- make sure q2m is not oversaturated qss = fpvs(t2m(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) + qss = eps * qss/(ps(i) + epsm1 * qss) q2m(i) = min(q2m(i),qss) + + ! Compute dew point, using vapor pressure + qv = max(qmin,(q2m(i)/(1.-q2m(i)))) + tem = max(ps(i) * qv/( eps - epsm1 *qv), 1.e-8) + dpt2m(i) = 243.5/( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + dpt2m(i) = min(dpt2m(i),t2m(i)) + + + if (debug_print) then + !-- diagnostics for a test point with known lat/lon + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + & abs(xlon_d(i)-testptlon).lt.0.2)then + print 100,'(ruc_lsm_diag) i=',i, & + & ' lat,lon=',xlat_d(i),xlon_d(i),'zf ',zf(i), & + & 'tskin ',tskin(i),'t2m ',t2m(i),'t1',t1(i),'shflx',shflx(i),& + & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & + & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & + & 'chs2 ',chs2(i),'cqs2 ',cqs2(i),'cqs ',cqs,'cdq',cdq(i) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) + enddo return diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index dd3bf79b8f..91a5c8d416 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -14,6 +14,36 @@ 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 +[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 [grav] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -46,6 +76,30 @@ type = real kind = kind_phys intent = in +[rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[wet] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [ps] standard_name = surface_air_pressure long_name = surface pressure @@ -71,7 +125,7 @@ kind = kind_phys intent = in [t1] - standard_name = air_temperature_of_new_state_at_surface_adjacent_layer + standard_name = air_temperature_at_surface_adjacent_layer long_name = 1st model layer air temperature units = K dimensions = (horizontal_loop_extent) @@ -79,7 +133,7 @@ kind = kind_phys intent = in [q1] - standard_name = specific_humidity_of_new_state_at_surface_adjacent_layer + standard_name = specific_humidity_at_surface_adjacent_layer long_name = 1st model layer specific humidity units = kg kg-1 dimensions = (horizontal_loop_extent) @@ -157,6 +211,60 @@ dimensions = () type = logical intent = in +[diag_flux] + standard_name = flag_for_flux_method_in_2m_diagnostics + long_name = flag for flux method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in +[diag_log] + standard_name = flag_for_log_method_in_2m_diagnostics + long_name = flag for log method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in +[shflx] + standard_name = surface_upward_temperature_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[chs2] + standard_name = surface_exchange_coefficient_for_heat_at_2m + long_name = exchange coefficient for heat at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cqs2] + standard_name = surface_exchange_coefficient_for_moisture_at_2m + long_name = exchange coefficient for moisture at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cdq] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm @@ -197,6 +305,14 @@ type = real kind = kind_phys intent = out +[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 = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 139f301374..16c8e8d17b 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -17,7 +17,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) - use machine, only: kind_phys, kind_dbl_prec + use machine, only: kind_phys implicit none @@ -34,7 +34,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con integer, intent(out) :: errflg integer :: i - real(kind=kind_dbl_prec) :: tem ! made dbl prec always, JM 20211104 + real(kind=kind_phys) :: tem ! Initialize CCPP error handling variables errmsg = '' @@ -65,9 +65,8 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con v10mmax(i) = v10m(i) endif ! Compute dew point, first using vapor pressure - tem = max(pgr(i) * q2m(i) / ( con_eps - con_epsm1 *q2m(i)), 1.d-8) - dpt2m(i) = 243.5_kind_dbl_prec / & - ( ( 17.67_kind_dbl_prec / log(tem/611.2_kind_dbl_prec) ) - 1.) + 273.14 + tem = max(pgr(i) * q2m(i) / ( con_eps - con_epsm1 *q2m(i)), 1.e-8) + dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 enddo endif diff --git a/physics/sflx.f b/physics/sflx.f index a020e217a3..87b2f757dd 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -1,7 +1,6 @@ !>\file sflx.f !! This file is the entity of GFS Noah LSM Model(Version 2.7). - module sflx - contains + !>\ingroup Noah_LSM !!\brief This is the entity of GFS Noah LSM model of physics subroutines. !! It is a soil/veg/snowpack land-surface model to update soil moisture, soil @@ -5804,4 +5803,3 @@ end subroutine wdfcnd !................................... end subroutine gfssflx !----------------------------------- - end module sflx diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index ae0f39dde9..348f455e18 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -112,7 +112,8 @@ subroutine sgscloud_radpre_run( & 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 + real :: a, f, sigq, qmq, qt, xl, th, thl, rsl, cpm, cb_cf + real(kind=kind_phys) :: tlk !Option to convective cloud fraction integer, parameter :: conv_cf_opt = 0 !0: C-B, 1: X-R @@ -188,7 +189,7 @@ subroutine sgscloud_radpre_run( & !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) + qc(i,k) = qc_bl(i,k) !eff radius cloud water (microns) from Miles et al. (2007) if (nint(slmsk(i)) == 1) then !land @@ -207,7 +208,7 @@ subroutine sgscloud_radpre_run( & 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) = ice_frac*qi_bl(i,k)*cldfra_bl(i,k) + qi(i,k) = ice_frac*qi_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.) @@ -220,7 +221,7 @@ subroutine sgscloud_radpre_run( & 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) + qs(i,k) = snow_frac*qi_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.) @@ -277,10 +278,11 @@ subroutine sgscloud_radpre_run( & !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 + !For now, GF mixing ratios are added elsewhere. + !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) + !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 @@ -321,10 +323,15 @@ subroutine sgscloud_radpre_run( & 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) + cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.0),0.99) + if (qci_conv(i,k) .lt. 1e-9) cb_cf = 0.0 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) + if (cb_cf .gt. 0.0) then + clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + else + !default to MYNN clouds - already specified + endif else ! unsaturated clouds1(i,k) = cb_cf endif diff --git a/physics/smoke/dep_dry_mod.F90 b/physics/smoke/dep_dry_mod.F90 new file mode 100755 index 0000000000..ea7dd99639 --- /dev/null +++ b/physics/smoke/dep_dry_mod.F90 @@ -0,0 +1,69 @@ +!>\file dep_dry_mod.F90 +!! This file is for the dry depostion driver. + +module dep_dry_mod + + use machine , only : kind_phys + + implicit none + + private + + public :: dry_dep_driver + +contains + + subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ndvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: ust, rmol + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: rel_hum + + REAL(kind_phys), PARAMETER :: kpart=500. + REAL(kind_phys) :: dvpart + +! +! Output array + REAL(kind_phys), DIMENSION( its:ite, jts:jte, ndvel ), INTENT(INOUT) :: ddvel + + + integer :: i,j,k,nv +! +! necessary for aerosols (module dependent) +! +! .. Intrinsic Functions .. + INTRINSIC max, min + +! compute dry deposition velocities = ddvel + + ddvel(:,:,:) = 0.0 + do nv = 1, ndvel + do j = jts, jte + do i = its, ite + dvpart = ust(i,j)/kpart + + IF (rmol(i,j)<0.) THEN ! UNSTABLE LAYERING CORRECTION + dvpart = dvpart*(1.+(-300.*rmol(i,j))**0.66667) + ENDIF + + IF (rel_hum(i,1,j)>0.8) THEN ! HIGH RELATIVE HUMIDITY CORRECTION + dvpart = dvpart*(1.+0.37*exp((rel_hum(i,1,j)-0.8)/0.2)) + END IF + ddvel(i,j,nv) = MIN(0.50,dvpart) ! m/s + enddo + enddo + enddo + +end subroutine dry_dep_driver + +end module dep_dry_mod diff --git a/smoke/dust_data_mod.F90 b/physics/smoke/dust_data_mod.F90 similarity index 97% rename from smoke/dust_data_mod.F90 rename to physics/smoke/dust_data_mod.F90 index 9e9713e22d..a710701f1f 100755 --- a/smoke/dust_data_mod.F90 +++ b/physics/smoke/dust_data_mod.F90 @@ -3,7 +3,6 @@ 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 @@ -80,8 +79,8 @@ module dust_data_mod ! -- 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 + real(kind_phys) :: dust_alpha = 2.2 + real(kind_phys) :: dust_gamma = 1.0 ! -- sea salt parameters diff --git a/smoke/dust_fengsha_mod.F90 b/physics/smoke/dust_fengsha_mod.F90 similarity index 54% rename from smoke/dust_fengsha_mod.F90 rename to physics/smoke/dust_fengsha_mod.F90 index fbf87aa560..82aec9b7c2 100755 --- a/smoke/dust_fengsha_mod.F90 +++ b/physics/smoke/dust_fengsha_mod.F90 @@ -9,7 +9,6 @@ module dust_fengsha_mod ! 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 @@ -21,7 +20,7 @@ module dust_fengsha_mod contains - subroutine gocart_dust_fengsha_driver(data, dt, & + subroutine gocart_dust_fengsha_driver(dt, & chem,rho_phy,smois,p8w,ssm, & isltyp,vegfra,snowh,xland,area,g,emis_dust, & ust,znt,clay,sand,rdrag,uthr, & @@ -30,47 +29,56 @@ subroutine gocart_dust_fengsha_driver(data, dt, & 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 + + ! 2d input variables + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm ! Sediment supply map + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra ! vegetative fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: snowh ! snow height (m) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: xland ! dominant land use type + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: area ! area of grid cell + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ust ! friction velocity + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: znt ! Surface Roughness length (m) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: clay ! Clay Fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: sand ! Sand Fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: rdrag ! Drag Partition (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: uthr ! Dry Threshold Velocity (m/s) + + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp ! soil type + + ! 3d input variables + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN) :: p8w + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN) :: rho_phy 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 + !0d input variables + REAL(kind_phys), INTENT(IN) :: dt ! time step + REAL(kind_phys), INTENT(IN) :: g ! gravity (m/s**2) + ! 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 + integer :: ilwi + real(kind_phys) :: airden ! air density + REAL(kind_phys) :: airmas ! dry air mass + real(kind_phys) :: dxy + real(kind_phys) :: conver,converi ! conversion values + real(kind_phys) :: R ! local drag partition + real(kind_phys) :: ustar + real(kind_phys), DIMENSION (num_emis_dust) :: tc + real(kind_phys), DIMENSION (num_emis_dust) :: bems + real(kind_phys), DIMENSION (num_emis_dust) :: distribution real(kind_phys), dimension (3) :: massfrac - real(kind_phys) :: conver,converi - real(kind_phys) :: R + real(kind_phys) :: erodtot + REAL(kind_phys) :: gravsm + REAL(kind_phys) :: drylimit - ! threshold values + ! conversion values conver=1.e-9 converi=1.e9 @@ -88,9 +96,9 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! Don't do dust over water!!! - ilwi(1,1)=0 + ilwi=0 if(xland(i,j).lt.1.5)then - ilwi(1,1)=1 + ilwi=1 ! Total concentration at lowest model level. This is still hardcoded for 5 bins. @@ -106,10 +114,10 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! 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) + airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g + airden=rho_phy(i,kts,j) + ustar=ust(i,j) + dxy=area(i,j) ! Mass fractions of clay, silt, and sand. massfrac(1)=clay(i,j) @@ -119,7 +127,7 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! Total erodibility. - erodtot(1,1) = ssm(i,j) ! SUM(erod(i,j,:)) + erodtot = 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 @@ -129,39 +137,39 @@ subroutine gocart_dust_fengsha_driver(data, dt, & ! Forthcoming... IF (znt(i,j) .gt. 0.2) then - ilwi(1,1)=0 + ilwi=0 endif ! limit where there is lots of vegetation if (vegfra(i,j) .gt. .17) then - ilwi(1,1) = 0 + ilwi = 0 endif ! limit where there is snow on the ground if (snowh(i,j) .gt. 0) then - ilwi(1,1) = 0 + ilwi = 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 + ilwi=0 ENDIF IF (isltyp(i,j) .eq. 0)then - ilwi(1,1)=0 + ilwi=0 endif - if(ilwi(1,1) == 0 ) cycle + if(ilwi == 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) + gravsm=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) + drylimit=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) + call fengsha_drag(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 @@ -174,9 +182,14 @@ subroutine gocart_dust_fengsha_driver(data, dt, & 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)) + + call source_dust(imx,jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & + erodtot, dxy, smois(i,1,j), airden, airmas, bems, g, dust_alpha, dust_gamma, & + R, uthr(i,j)) + +! call source_dust(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 @@ -209,17 +222,20 @@ subroutine gocart_dust_fengsha_driver(data, dt, & 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) + ! SUBROUTINE source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & + ! erod, dxy, gravsm, airden, airmas, bems, g0, drylimit, alpha, & + ! gamma, R, uthres) + + subroutine source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & + erod, dxy, smois, airden, airmas, bems, g0, 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) + ! * smois Volumetric soil moisture (m3/m3) ! * ALPHA Constant to fudge the total emission of dust (1/m) ! * GAMMA Tuning constant for erodibility (-) ! * DXY Surface of each grid cell (m2) @@ -236,8 +252,7 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! * UTHRES FENGSHA Dry Threshold Velocities (m/s) ! * ! * Data: - ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) - ! * SPOINT Pointer to 3 soil classes (-) + ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) (clay silt sand) ! * DEN_DUST Dust density (kg/m3) ! * DEN_SALT Saltation particle density (kg/m3) ! * REFF_SALT Reference saltation particle diameter (m) @@ -269,6 +284,9 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! * EMIT Total vertical mass flux (kg/m2/s) ! * EMIT_VOL Total vertical volume flux (m/s) ! * DSRC Mass of emitted dust (kg/timestep/cell) + ! * RHOSOIL Density of Soil (kg/m3) + ! * SALT total saltation + ! * SALTBIN total saltation in bin ! * ! * Output: ! * TC Total concentration of dust (kg/kg/timestep/cell) @@ -276,52 +294,56 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! * ! **************************************************************************** implicit none - type(smoke_data), intent(inout) :: data + ! Input 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) :: ustar 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) :: erod + REAL(kind_phys), INTENT(IN) :: dxy + REAL(kind_phys), INTENT(IN) :: smois + REAL(kind_phys), INTENT(IN) :: airden + REAL(kind_phys), INTENT(IN) :: airmas 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 + ! Output + REAL(kind_phys), INTENT(INOUT) :: tc(nmx) + + ! Local Variables + REAL(kind_phys), INTENT(OUT) :: bems(nmx) + + REAL(kind_phys) :: saltbin(smx) + REAL(kind_phys) :: den(smx) + REAL(kind_phys) :: diam(smx) + REAL(kind_phys) :: dvol(nmx) + REAL(kind_phys) :: distr_dust(nmx) + REAL(kind_phys) :: dlndp(nmx) + REAL(kind_phys) :: dsurface(smx) + REAL(kind_phys) :: ds_rel(smx) + REAL(kind_phys) :: u_ts0 + REAL(kind_phys) :: u_ts + REAL(kind_phys) :: dsrc + REAL(kind_phys) :: dmass + REAL(kind_phys) :: dvol_tot + REAL(kind_phys) :: salt + REAL(kind_phys) :: emit + REAL(kind_phys) :: emit_vol + REAL(kind_phys) :: stotal + REAL(kind_phys) :: rhoa + REAL(kind_phys) :: 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(kind_phys), PARAMETER :: kvhmax=2.0e-4 ! REAL, PARAMETER :: cmb=2.61 ! from White,1979 ! Parameters used in Kok distribution function. Advise not to play with @@ -332,6 +354,7 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, 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 + REAL(kind_phys), PARAMETER :: RHOSOIL=2650. ! Calculate saltation surface area distribution from sand, silt, and clay ! mass fractions and saltation bin fraction. This will later become a @@ -365,69 +388,23 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! Set DRY threshold friction velocity to input value u_ts0 = uthres - g = g0*1.0E2 + ! g = g0*1.0E2 + g = g0 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 + !rhoa = airden*1.0D-3 ! (g cm^-3) + rhoa = airden + call DustEmissionFENGSHA(smois,massfrac(1),massfrac(3), massfrac(2), & + erod, R, rhoa, ustar, uthres, alpha, gamma, kvhmax, & + g, RHOSOIL, salt) + + saltbin(n) = salt * cmb * ds_rel(n) + + ! EROD is taken into account above + emit = emit + salt END DO ! Now that we have the total dust emission, distribute into dust bins using @@ -460,92 +437,24 @@ SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, ! 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 + ! Calculate total mass emitted + dsrc = emit*distr_dust(n)*dxy*dt1 ! (kg) + IF (dsrc < 0.0) dsrc = 0.0 + + ! Update dust mixing ratio at first model level. + tc(n) = tc(n) + dsrc / airmas ! (kg/kg) + ! bems(i,j,n) = dsrc ! diagnostic + !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) + bems(n) = 1.e+9*dsrc/(dxy*dt1) ! diagnostic (ug/m2/s) !lzhang + END DO + tc(1)=tc(1)+tc(2) ! This is just for RRFS-SD. DO NOT use in other models!!! 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) + subroutine fengsha_drag(z0,R) implicit none - type(smoke_data), intent(inout) :: data real(kind_phys), intent(in) :: z0 real(kind_phys), intent(out) :: R @@ -567,35 +476,198 @@ subroutine fengsha_drag(data,z0,R) 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 ) + subroutine DustEmissionFENGSHA(slc, clay, sand, silt, & + ssm, rdrag, airdens, ustar, uthrs, alpha, gamma, & + kvhmax, grav, rhop, emissions) + + ! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of soil layer, volumetric fraction [1] + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] + REAL(kind_phys), intent(in) :: silt ! fractional silt content [1] + REAL(kind_phys), intent(in) :: ssm ! erosion map [1] + REAL(kind_phys), intent(in) :: rdrag ! drag partition [1/m] + REAL(kind_phys), intent(in) :: airdens ! air density at lowest level [kg/m^3] + REAL(kind_phys), intent(in) :: ustar ! friction velocity [m/sec] + REAL(kind_phys), intent(in) :: uthrs ! threshold velocity [m/2] + REAL(kind_phys), intent(in) :: alpha ! scaling factor [1] + REAL(kind_phys), intent(in) :: gamma ! scaling factor [1] + REAL(kind_phys), intent(in) :: kvhmax ! max. vertical to horizontal mass flux ratio [1] + REAL(kind_phys), intent(in) :: grav ! gravity [m/sec^2] + REAL(kind_phys), intent(in) :: rhop ! soil class density [kg/m^3] + + ! !OUTPUT PARAMETERS: + REAL(kind_phys), intent(inout) :: emissions ! binned surface emissions [kg/(m^2 sec)] + + ! !DESCRIPTION: Compute dust emissions using NOAA/ARL FENGSHA model ! - ! 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] + ! !REVISION HISTORY: ! - !-------------------------------------------------------------------- - 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 + ! 22Feb2020 B.Baker/NOAA - Original implementation + ! 29Mar2021 R.Montuoro/NOAA - Refactored for process library + ! 09Aug2022 B.Baker/NOAA - Adapted for CCPP-Physics + + ! !Local Variables + real(kind_phys) :: alpha_grav + real(kind_phys) :: h + real(kind_phys) :: kvh + real(kind_phys) :: q + real(kind_phys) :: rustar + real(kind_phys) :: total_emissions + real(kind_phys) :: u_sum, u_thresh + +!EOP +!------------------------------------------------------------------------- +! Begin + +! Initialize emissions +! -------------------- + emissions = 0. + +! Prepare scaling factor +! ---------------------- + alpha_grav = alpha / grav + + ! Compute vertical-to-horizontal mass flux ratio + ! ---------------------------------------------- + kvh = DustFluxV2HRatioMB95(clay, kvhmax) + + ! Compute total emissions + ! ----------------------- + emissions = alpha_grav * (ssm ** gamma) * airdens * kvh + + ! Compute threshold wind friction velocity using drag partition + ! ------------------------------------------------------------- + rustar = rdrag * ustar + + ! Now compute size-dependent total emission flux + ! ---------------------------------------------- + ! Fecan moisture correction + ! ------------------------- + h = moistureCorrectionFecan(slc, sand, clay, rhop) + + ! Adjust threshold + ! ---------------- + u_thresh = uthrs * h + + u_sum = rustar + u_thresh + + ! Compute Horizontal Saltation Flux according to Eq (9) in Webb et al. (2020) + ! --------------------------------------------------------------------------- + q = max(0., rustar - u_thresh) * u_sum * u_sum + + ! Distribute emissions to bins and convert to mass flux (kg s-1) + ! -------------------------------------------------------------- + emissions = emissions * q + + + end subroutine DustEmissionFENGSHA +!----------------------------------------------------------------- + real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: vsoil ! volumetric soil moisture fraction [1] + REAL(kind_phys), intent(in) :: sandfrac ! fractional sand content [1] + REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] + +! !DESCRIPTION: Convert soil moisture fraction from volumetric to gravimetric. +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library - real(kind_phys), intent(out) :: salt - real(kind_phys) :: Q - Q = ust * (ust * ust - utst * utst) - salt = Q ! sdep * kvh * Q +! !Local Variables + real :: vsat - return - end subroutine fengsha_hflux +! !CONSTANTS: + REAL(kind_phys), parameter :: rhow = 1000. ! density of water [kg m-3] + +!EOP +!------------------------------------------------------------------------- +! Begin... + +! Saturated volumetric water content (sand-dependent) ! [m3 m-3] + vsat = 0.489 - 0.00126 * ( 100. * sandfrac ) + +! Gravimetric soil content + soilMoistureConvertVol2Grav = vsoil * rhow / (rhop * (1. - vsat)) + + end function soilMoistureConvertVol2Grav +!---------------------------------------------------------------- + real function moistureCorrectionFecan(slc, sand, clay, rhop) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1] + REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] + +! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library + +! !Local Variables + real :: grvsoilm + real :: drylimit + +!EOP +!--------------------------------------------------------------- +! Begin... + +! Convert soil moisture from volumetric to gravimetric + grvsoilm = soilMoistureConvertVol2Grav(slc, sand, 2650.) + +! Compute fecan dry limit + drylimit = clay * (14.0 * clay + 17.0) + +! Compute soil moisture correction + moistureCorrectionFecan = sqrt(1.0 + 1.21 * max(0., grvsoilm - drylimit)**0.68) + end function moistureCorrectionFecan +!--------------------------------------------------------------- + real function DustFluxV2HRatioMB95(clay, kvhmax) +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: kvhmax ! maximum flux ratio [1] + +! !CONSTANTS: + REAL(kind_phys), parameter :: clay_thresh = 0.2 ! clay fraction above which the maximum flux ratio is returned + +! !DESCRIPTION: Computes the vertical-to-horizontal dust flux ratio according to +! B.Marticorena, G.Bergametti, J.Geophys.Res., 100(D8), 164! doi:10.1029/95JD00690 +! +! !REVISION HISTORY: +! +! 22Feb2020 B.Baker/NOAA - Original implementation +! 01Apr2021 R.Montuoro/NOAA - Adapted for GOCART process library +! +!EOP +!------------------------------------------------------------------------- +! Begin... + + if (clay > clay_thresh) then + DustFluxV2HRatioMB95 = kvhmax + else + DustFluxV2HRatioMB95 = 10.0**(13.4*clay-6.0) + end if + + end function DustFluxV2HRatioMB95 + end module dust_fengsha_mod diff --git a/smoke/module_add_emiss_burn.F90 b/physics/smoke/module_add_emiss_burn.F90 similarity index 91% rename from smoke/module_add_emiss_burn.F90 rename to physics/smoke/module_add_emiss_burn.F90 index da35535f75..ff53f74139 100755 --- a/smoke/module_add_emiss_burn.F90 +++ b/physics/smoke/module_add_emiss_burn.F90 @@ -4,15 +4,14 @@ 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, & + subroutine add_emis_burn(dtstep,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, & + r_q,fhist,ext3d_smoke,ext3d_dust, & ! nwfa,nifa, & rainc,rainnc, swdown,smoke_forecast, & ids,ide, jds,jde, kds,kde, & @@ -22,11 +21,10 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & ! 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, & + INTEGER, INTENT(IN ) :: julday, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -40,7 +38,7 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & 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: + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: ext3d_smoke, ext3d_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 @@ -51,7 +49,7 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & 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, 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 @@ -148,7 +146,7 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & ! r_q(i,j)= fhist(i,j) ! no diurnal cycle !END IF - !IF (.NOT. smoke_forecast) THEN + !IF (smoke_forecast == 0) THEN r_q(i,j)= 1. !END IF @@ -174,21 +172,19 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & 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(6,*) 'add_emiss_burn: gmt,dtstep,time_int ',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 + if ( dbg_opt .and. (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 @@ -204,17 +200,17 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & 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) + ext3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) + ext3d_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 + IF ( 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) + WRITE(*,*) 'add_emis_burn: ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) ',ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) ',ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) END IF ! CASE DEFAULT diff --git a/smoke/module_plumerise1.F90 b/physics/smoke/module_plumerise1.F90 similarity index 91% rename from smoke/module_plumerise1.F90 rename to physics/smoke/module_plumerise1.F90 index 47bb4e74a3..3c23faa6ab 100755 --- a/smoke/module_plumerise1.F90 +++ b/physics/smoke/module_plumerise1.F90 @@ -3,7 +3,6 @@ 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 @@ -35,10 +34,10 @@ module module_plumerise1 ! 'aggr' /) ! grassland CONTAINS -subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & +subroutine ebu_driver ( 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,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags + z_at_w,z,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, & @@ -49,7 +48,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & 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 @@ -58,8 +56,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! 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, & + INTEGER, INTENT(IN ) :: 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 ), & @@ -98,7 +95,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,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) @@ -115,12 +111,12 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & cpor =con_cp/con_rd con_rocp=con_rd/con_cp - IF ( dbg_opt .and. ktau<2000) then + IF ( dbg_opt ) 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 + 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 @@ -136,7 +132,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! 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. @@ -145,13 +140,12 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & 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 +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 @@ -175,7 +169,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp enddo - IF (dbg_opt .and. ktau<2000) then + IF (dbg_opt) 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) @@ -185,15 +179,15 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & END IF ! RAR: the plume rise calculation step: - CALL plumerise(data,kte,1,1,1,1,1,1, & + CALL plumerise(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, g, con_cp, & + k_max(i,j), dbg_opt, g, con_cp, & con_rd, cpor, errmsg, errflg ) - !k_max(i,j), ktau, config_flags%debug_chem ) + !k_max(i,j), config_flags%debug_chem ) if(errflg/=0) return kp1= k_min(i,j) @@ -205,7 +199,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & enddo ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) - IF ( dbg_opt .and. ktau<2000) then + IF ( dbg_opt ) 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 @@ -213,7 +207,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & enddo enddo -! ENDIF check_pl + ENDIF check_pl end subroutine ebu_driver diff --git a/smoke/module_smoke_plumerise.F90 b/physics/smoke/module_smoke_plumerise.F90 similarity index 99% rename from smoke/module_smoke_plumerise.F90 rename to physics/smoke/module_smoke_plumerise.F90 index 247b09f923..a895b0b8ed 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/physics/smoke/module_smoke_plumerise.F90 @@ -14,8 +14,6 @@ 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 plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & !tropical_forest, boreal_forest, savannah, grassland, & wind_eff @@ -26,15 +24,14 @@ module module_smoke_plumerise CONTAINS ! RAR: - subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & + subroutine plumerise(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, g, cp, rgas, & + frp_inst,k1,k2, dbg_opt, g, cp, rgas, & cpor, errmsg, errflg ) implicit none - type(smoke_data), intent(inout) :: data LOGICAL, INTENT (IN) :: dbg_opt @@ -46,7 +43,6 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & 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 character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -106,9 +102,6 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & !---------------------------------------------------------------------- ! print *,' Plumerise_scalar 1',ncall coms => get_thread_coms() - if (ktau==2) then - call coms%set_to_zero() - endif IF (frp_inst=k1+1 @@ -208,7 +199,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! enddo !enddo - IF (dbg_opt .AND. ktau<2000) then + IF (dbg_opt) 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) @@ -220,7 +211,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,g,cp,rgas,cpor,errmsg,errflg) +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,g,cp,rgas,cpor,errmsg,errflg) !se module_zero_plumegen_coms !use rconstants @@ -232,11 +223,11 @@ subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg, 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 +integer :: wind_eff character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg -if(ktau==2) then +if(.not.coms%initialized) then ! n_setgrid = 1 call set_grid(coms) ! define vertical grid of plume model ! coms%zt(k) = thermo and water levels @@ -348,6 +339,8 @@ subroutine set_grid(coms) 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%initialized = .true. ! coms%dzm(1) = 0.5/coms%dz ! coms%dzm(2:mzp) = 1./coms%dz diff --git a/physics/smoke/module_wetdep_ls.F90 b/physics/smoke/module_wetdep_ls.F90 new file mode 100755 index 0000000000..87212920bd --- /dev/null +++ b/physics/smoke/module_wetdep_ls.F90 @@ -0,0 +1,79 @@ +!>\file module_wetdep_ls.F90 +!! This file contains aerosol wet deposition module. + +module module_wetdep_ls + use machine , only : kind_phys + use rrfs_smoke_config, only : p_qc, alpha => wetdep_ls_alpha + +contains +subroutine wetdep_ls(dt,var,rain,moist, & + rho,nchem,num_moist,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + implicit none + + integer, intent(in) :: nchem, num_moist, & + 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:nchem),intent(inout) :: var + real(kind_phys), dimension( ims:ime, jms:jme),intent(in) :: rain + real(kind_phys), dimension( its:ite, jts:jte) :: var_sum,var_rmv + 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,clsum + integer :: nv,i,j,k,km,kb,kbeg + !real(kind_phys), parameter :: alpha = .5 ! scavenging factor + + + do nv=1,nchem + do i=its,ite + do j=jts,jte + var_sum_clw(i,j)=0. + var_sum(i,j)=0. + var_rmvl(i,:,j)=0. + frc(i,j)=0. + rain_clw(i,j)=0. + if(rain(i,j).gt.1.e-10)then +! convert rain back to rate +! + rain_clw(i,j)=rain(i,j)/dt +! total cloud water +! + do k=1,kte-1 + dvar=max(0.,moist(i,k,j,p_qc)*rho(i,k,j)*vvel(i,k,j)*dz8w(i,k,j)) + var_sum_clw(i,j)=var_sum_clw(i,j)+dvar + var_sum(i,j)=var_sum(i,j)+var(i,k,j,nv)*rho(i,k,j) + enddo + if(var_sum(i,j).gt.1.e-10 .and. var_sum_clw(i,j).gt.1.e-10 ) then +! assuming that frc is onstant, it is my conversion factor +! (just like in convec. parameterization) + frc(i,j)=rain_clw(i,j)/var_sum_clw(i,j) + frc(i,j)=max(1.e-6,min(frc(i,j),.005)) + endif + endif + enddo + enddo +! +! get rid of it +! + do i=its,ite + do j=jts,jte + if(rain(i,j).gt.1.e-10 .and. var_sum(i,j).gt.1.e-10 .and. var_sum_clw(i,j).gt.1.e-10)then + do k=kts,kte-2 + if(var(i,k,j,nv).gt.1.e-16 .and. moist(i,k,j,p_qc).gt.0.)then + factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) + dvar=alpha*factor/(1+factor)*var(i,k,j,nv) + var(i,k,j,nv)=max(1.e-16,var(i,k,j,nv)-dvar) + endif + enddo + endif + enddo + enddo + enddo ! nv +end subroutine wetdep_ls +end module module_wetdep_ls diff --git a/smoke/module_zero_plumegen_coms.F90 b/physics/smoke/module_zero_plumegen_coms.F90 similarity index 88% rename from smoke/module_zero_plumegen_coms.F90 rename to physics/smoke/module_zero_plumegen_coms.F90 index 622d6a813d..92b9ca2dcc 100755 --- a/smoke/module_zero_plumegen_coms.F90 +++ b/physics/smoke/module_zero_plumegen_coms.F90 @@ -9,6 +9,8 @@ module module_zero_plumegen_coms integer, parameter :: nkp = 200, ntime = 200 type plumegen_coms + logical :: initialized = .false. + real(kind=kind_phys),dimension(nkp) :: w,t,qv,qc,qh,qi,sc, & ! blob vth,vti,rho,txs, & est,qsat! never used: ,qpas,qtotal @@ -55,38 +57,28 @@ module module_zero_plumegen_coms 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. + type(plumegen_coms), private, pointer :: private_thread_coms !$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. + if(.not.associated(private_thread_coms)) then + allocate(private_thread_coms) + call plumegen_coms_zero(private_thread_coms) 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%initialized = .false. + this%w=0.0 this%t=0.0 this%qv=0.0 diff --git a/smoke/plume_data_mod.F90 b/physics/smoke/plume_data_mod.F90 similarity index 100% rename from smoke/plume_data_mod.F90 rename to physics/smoke/plume_data_mod.F90 diff --git a/smoke/rrfs_smoke_config.F90 b/physics/smoke/rrfs_smoke_config.F90 similarity index 67% rename from smoke/rrfs_smoke_config.F90 rename to physics/smoke/rrfs_smoke_config.F90 index 43b3aee144..cdcf8fc8f6 100755 --- a/smoke/rrfs_smoke_config.F90 +++ b/physics/smoke/rrfs_smoke_config.F90 @@ -16,59 +16,29 @@ module rrfs_smoke_config !-- constant paramters real(kind=kind_phys), parameter :: epsilc = 1.e-12 - !-- chemistyr module configurations + !-- aerosol 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 :: plumerisefire_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 :: smoke_forecast = 0 ! 0 read in ebb_smoke(i,24) + real(kind_phys) :: wetdep_ls_alpha = .5 ! scavenging factor ! -- + integer, parameter :: CHEM_OPT_GOCART= 1 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 @@ -77,12 +47,9 @@ module rrfs_smoke_config ! -- 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 diff --git a/smoke/rrfs_smoke_postpbl.F90 b/physics/smoke/rrfs_smoke_postpbl.F90 similarity index 73% rename from smoke/rrfs_smoke_postpbl.F90 rename to physics/smoke/rrfs_smoke_postpbl.F90 index f83aaf7953..93fed46bfc 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/physics/smoke/rrfs_smoke_postpbl.F90 @@ -15,16 +15,11 @@ module rrfs_smoke_postpbl contains -!>\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 +!> \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) + qgrs, chem3d, rrfs_sd, errmsg, errflg) implicit none @@ -35,6 +30,7 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + logical, intent(in) :: rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -44,6 +40,8 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & errmsg = '' errflg = 0 + if (.not. rrfs_sd) return + !--- put smoke stuff back into tracer array do k=kts,kte @@ -53,7 +51,8 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & enddo enddo - end subroutine rrfs_smoke_postpbl_run + return + + end subroutine rrfs_smoke_postpbl_run -!> @} end module rrfs_smoke_postpbl diff --git a/smoke/rrfs_smoke_postpbl.meta b/physics/smoke/rrfs_smoke_postpbl.meta similarity index 77% rename from smoke/rrfs_smoke_postpbl.meta rename to physics/smoke/rrfs_smoke_postpbl.meta index 99aae69f2f..df841be8cd 100755 --- a/smoke/rrfs_smoke_postpbl.meta +++ b/physics/smoke/rrfs_smoke_postpbl.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = rrfs_smoke_wrapper + name = rrfs_smoke_postpbl 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 + dependencies = dep_dry_mod.F90,module_wetdep_ls.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,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 ######################################################################## [ccpp-arg-table] - name = rrfs_smoke_wrapper_run + name = rrfs_smoke_postpbl_run type = scheme [ite] standard_name = horizontal_loop_extent @@ -58,6 +58,13 @@ type = real kind = kind_phys intent = inout +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke/rrfs_smoke_wrapper.F90 similarity index 74% rename from smoke/rrfs_smoke_wrapper.F90 rename to physics/smoke/rrfs_smoke_wrapper.F90 index ac32e1ad45..7c2c88345a 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke/rrfs_smoke_wrapper.F90 @@ -1,5 +1,5 @@ !>\file rrfs_smoke_wrapper.F90 -!! This file is CCPP RRFS smoke driver +!! This file is CCPP driver of RRFS Smoke and Dust !! Haiqin.Li@noaa.gov 02/2021 module rrfs_smoke_wrapper @@ -13,7 +13,7 @@ module rrfs_smoke_wrapper use module_plumerise1 !plume_rise_mod use module_add_emiss_burn use dep_dry_mod - use rrfs_smoke_data + use module_wetdep_ls implicit none @@ -31,28 +31,31 @@ module rrfs_smoke_wrapper !! !>\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, & + 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, 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, & - 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, & + dust12m_in, emi_in, smoke_RRFS, 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, wetness, & + smoke_ext, dust_ext, ndvel, ddvel_inout,rrfs_sd, & + dust_alpha_in, dust_gamma_in, fire_in, & + seas_opt_in, dust_opt_in, drydep_opt_in, & + do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + wetdep_ls_opt_in,wetdep_ls_alpha_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 + integer, intent(in) :: ntrac, ntsmoke, ntdust, ndvel 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 + logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in + integer, intent(in) :: smoke_forecast_in integer, parameter :: ids=1,jds=1,jde=1, kds=1 integer, parameter :: ims=1,jms=1,jme=1, kms=1 @@ -61,7 +64,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, 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) :: smoke_RRFS 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, & @@ -75,14 +78,19 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, 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) :: fire_in 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 + real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout + real (kind=kind_phys), dimension(:), intent(in) :: wetness 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 + real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in + integer, intent(in) :: seas_opt_in, dust_opt_in, & + drydep_opt_in, plumerisefire_frq_in, & + addsmoke_flag_in, wetdep_ls_opt_in + logical, intent(in ) :: do_plumerise_in, rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -97,7 +105,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, 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 @@ -115,22 +122,17 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, 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 + real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: ext3d_smoke, ext3d_dust integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 - real(kind_phys) :: dtstep - logical :: call_plume, scale_fire_emiss + logical :: call_fire !>- optical variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum + real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel !>-- 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 @@ -145,23 +147,20 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys) :: daero_emis_wfa, daero_emis_ifa !>-- local variables real(kind_phys), dimension(im) :: wdgust, snoweq - integer :: current_month, current_hour + integer :: current_month, current_hour, hour_int 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() + integer :: i, j, k, kp, n errmsg = '' errflg = 0 + if (.not. rrfs_sd) return + !>-- 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 @@ -169,46 +168,39 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, smoke_forecast = smoke_forecast_in aero_ind_fdb = aero_ind_fdb_in dbg_opt = dbg_opt_in + wetdep_ls_opt = wetdep_ls_opt_in + wetdep_ls_alpha = wetdep_ls_alpha_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. + ext3d_smoke = 0. + ext3d_dust = 0. rcav = 0. rnav = 0. curr_secs = ktau * dt - current_month=jdate(2) - current_hour =jdate(5)+1 - gmt = real(idat(5)) + current_month=jdate(2) ! needed for the dust input data + current_hour =jdate(5)+1 ! =1 at 00Z + hour_int=ktau*dt/3600. ! hours since the simulation start + gmt = real(mod(idat(5)+hour_int,24)) 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 + do nv=1,ndvel + do i=its,ite + ddvel(i,1,nv)=ddvel_inout(i,nv) + enddo + enddo ! -- compute incremental convective and large-scale rainfall do i=its,ite @@ -220,34 +212,23 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! 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) + call_fire = (do_plumerise .and. (plumerisefire_frq > 0)) + if (call_fire) call_fire = (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, & + current_month, current_hour, gmt, & 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, g, pi, & + snow,dust12m_in,emi_in,smoke_RRFS, & + hf2d, pb2d, g, pi, hour_int, & 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, & + num_chem,num_moist, & ntsmoke, ntdust, & moist,chem,plume_frp,ebu_in, & ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & @@ -259,25 +240,32 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! Make this global, calculate at 1st time step only !>-- for plumerise -- -!IF (ktau==1) THEN + + do j=jts,jte + do i=its,ite + peak_hr(i,j)= fire_in(i,10) + enddo + enddo + + IF (ktau==1) THEN do j=jts,jte do i=its,ite - if (xlong(i,j)<-130.) then + if (xlong(i,j)<230.) then peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska - elseif(xlong(i,j)<-115.) then + elseif(xlong(i,j)<245.) then peak_hr(i,j)= 23.0* 3600. - elseif (xlong(i,j)<-100.) then + elseif (xlong(i,j)<260.) then peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US - elseif (xlong(i,j)<-85.) then + elseif (xlong(i,j)<275.) then peak_hr(i,j)= 21.0* 3600. - elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US + elseif (xlong(i,j)<290.) 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 + ENDIF IF (ktau==1) THEN ebu = 0. @@ -299,9 +287,9 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- compute sea-salt - ! -- compute sea salt - if (seas_opt >= SEAS_OPT_DEFAULT) then - call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & + ! -- compute sea salt (opt=2) + if (seas_opt == 2) then + call gocart_seasalt_driver(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,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & @@ -310,18 +298,19 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, its,ite, jts,jte, kts,kte) endif - !-- compute dust - select case (dust_opt) - case (DUST_OPT_FENGSHA) + !-- compute dust (opt=5) + if (dust_opt==DUST_OPT_FENGSHA) then ! Set at compile time in dust_data_mod: - call gocart_dust_fengsha_driver(data,dt,chem,rho_phy,smois,p8w,ssm, & + dust_alpha = dust_alpha_in + dust_gamma = dust_gamma_in + call gocart_dust_fengsha_driver(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 + end if ! compute wild-fire plumes !-- to add a namelist option to turn on/off plume raising @@ -329,13 +318,12 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !-- /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 + if (call_fire) then call ebu_driver ( & - data,flam_frac,ebu_in,ebu, & + flam_frac,ebu_in,ebu, & t_phy,moist(:,:,:,p_qv), & rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,zmid,ktau,g,con_cp,con_rd, & + z_at_w,zmid,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, & @@ -345,34 +333,41 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! -- 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, & + call add_emis_burn(dt,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), ! & + coef_bb_dc,fire_hist,ext3d_smoke,ext3d_dust, & 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, & + call dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) + + do nv=1,ndvel + do i=its,ite + ddvel_inout(i,nv)=ddvel(i,1,nv) + enddo + enddo + else + ddvel_inout(:,:)=0. + endif + +!>- large-scale wet deposition + if (wetdep_ls_opt == 1) then + call wetdep_ls(dt,chem,rnav,moist, & + rho_phy,num_chem,num_moist,dz8w,vvel, & + 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 @@ -384,25 +379,24 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !---- 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) + wdgust(i)=max(1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2),3.) + snoweq(i)=max((25.-snow(i))/25.,0.) + hwp(i)=0.237*wdgust(i)**1.11*max(t2m(i)-dpt2m(i),15.)**0.92*((1.-wetness(i))**6.95)*snoweq(i) ! Eric 08/2022 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) + smoke_ext(i,k) = ext3d_smoke(i,k,1) + dust_ext (i,k) = ext3d_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)) + gq0(i,k,ntsmoke )= max(epsilc,chem(i,k,1,p_smoke )) + gq0(i,k,ntdust )= max(epsilc,chem(i,k,1,p_dust_1)) enddo enddo @@ -416,7 +410,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, 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 @@ -427,7 +420,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, max_fplume (i) = real(max_fplume2(i,1)) enddo -! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau + do i = 1, im + fire_in(i,10) = peak_hr(i,1) + enddo + !-- 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 @@ -453,26 +449,23 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, 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, & + current_month,current_hour,gmt, & 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, g, pi, & + snow_cpl,dust12m_in,emi_in,smoke_RRFS, & + hf2d, pb2d, g, pi, hour_int, & 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, & + num_chem, num_moist, & 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, & @@ -482,19 +475,19 @@ subroutine rrfs_smoke_prep( & its,ite, jts,jte, kts,kte) !Chem input configuration - integer, intent(in) :: ktau, current_month, current_hour + integer, intent(in) :: current_month, current_hour, hour_int !FV3 input variables 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), intent(in) :: g, pi, gmt 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, 24, 3), intent(in) :: smoke_RRFS 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) :: & @@ -503,15 +496,12 @@ subroutine rrfs_smoke_prep( & !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 @@ -534,7 +524,7 @@ subroutine rrfs_smoke_prep( & 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 + integer i,ip,j,k,kp,kk,kkp,nv,l,ll,n ! -- initialize fire emissions !plume = 0._kind_phys @@ -542,6 +532,8 @@ subroutine rrfs_smoke_prep( & ebu_in = 0._kind_phys ebb_smoke_hr = 0._kind_phys emis_anoc = 0._kind_phys + frp_hr = 0._kind_phys + frp_std_hr = 0._kind_phys ! -- initialize output arrays isltyp = 0._kind_phys @@ -617,75 +609,57 @@ subroutine rrfs_smoke_prep( & 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 + do i=its,ite + z_at_w(i,kts,j)=max(0.,ph3d(i,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 + do k=kts,kte + do i=its,ite + dz8w(i,k,j)=abs(ph3d(i,k+1)-ph3d(i,k))/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 + do k=kts,kte+1 + do i=its,ite + p8w(i,k,j)=pr3d(i,k) 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))) + t_phy(i,k,j)=tk3d(i,kkp) + p_phy(i,k,j)=prl3d(i,kkp) + u_phy(i,k,j)=us3d(i,kkp) + v_phy(i,k,j)=vs3d(i,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(i,kkp))) rri(i,k,j)=1./rho_phy(i,k,j) - vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. - moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + moist(i,k,j,1)=gq0(i,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,2)=gq0(i,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) + moist(i,k,j,3)=gq0(i,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)) + rel_hum(i,k,j) = min(0.95,spechum(i,kkp)) + rel_hum(i,k,j) = max(0.1,rel_hum(i,k,j)) !-- - zmid(i,k,j)=phl3d(ip,kkp)/g + zmid(i,k,j)=phl3d(i,kkp)/g enddo enddo enddo @@ -705,7 +679,6 @@ subroutine rrfs_smoke_prep( & enddo enddo - ! -- only used in phtolysis.... do j=jts,jte do i=its,ite t8w(i,1,j)=t_phy(i,1,j) @@ -718,27 +691,25 @@ subroutine rrfs_smoke_prep( & emis_anoc(i) = emi_in(i,1) enddo - ! select case (plumerise_flag) - ! case (FIRE_OPT_GBBEPx) + if (hour_int<24) then 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 + ebb_smoke_hr(i) = smoke_RRFS(i,hour_int+1,1) ! smoke + frp_hr (i) = smoke_RRFS(i,hour_int+1,2) ! frp + frp_std_hr (i) = smoke_RRFS(i,hour_int+1,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 + endif ! 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)) + chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke)) + chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )) enddo enddo diff --git a/smoke/rrfs_smoke_wrapper.meta b/physics/smoke/rrfs_smoke_wrapper.meta similarity index 87% rename from smoke/rrfs_smoke_wrapper.meta rename to physics/smoke/rrfs_smoke_wrapper.meta index ef46b04eaf..8280084c72 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/physics/smoke/rrfs_smoke_wrapper.meta @@ -1,7 +1,7 @@ [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 + dependencies = dep_dry_mod.F90,module_wetdep_ls.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,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 ######################################################################## [ccpp-arg-table] @@ -263,9 +263,9 @@ kind = kind_phys intent = in [snow] - standard_name = lwe_thickness_of_snow_amount - long_name = snow fall on physics timestep - units = m + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -365,9 +365,9 @@ type = real kind = kind_phys intent = in -[smoke_GBBEPx] - standard_name = emission_smoke_GBBEPx - long_name = emission fire GBBEPx +[smoke_RRFS] + standard_name = emission_smoke_RRFS + long_name = emission fire RRFS units = various dimensions = (horizontal_loop_extent,24,3) type = real @@ -551,6 +551,14 @@ type = real kind = kind_phys intent = out +[wetness] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [smoke_ext] standard_name = extinction_coefficient_in_air_due_to_smoke long_name = extinction coefficient in air due to smoke @@ -567,6 +575,52 @@ type = real kind = kind_phys intent = out +[ndvel] + standard_name = number_of_chemical_species_deposited + long_name = number of chemical pbl deposited + units = count + dimensions = () + type = integer + intent = in +[ddvel_inout] + standard_name = dry_deposition_velocity_mynn_pbl_transport + long_name = dry deposition velocity by mynn pbl transport + units = m s-1 + dimensions = (horizontal_loop_extent,2) + type = real + kind = kind_phys + intent = inout +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dust_alpha_in] + standard_name = alpha_fengsha_dust_scheme + long_name = alpha paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dust_gamma_in] + standard_name = gamma_fengsha_dust_scheme + long_name = gamma paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[fire_in] + standard_name = smoke_fire_auxiliary_input + long_name = smoke fire auxiliary input variables + units = various + dimensions = (horizontal_loop_extent,fire_auxiliary_data_extent) + type = real + kind = kind_phys + intent = inout [seas_opt_in] standard_name = control_for_smoke_sea_salt long_name = rrfs smoke sea salt emission option @@ -581,20 +635,28 @@ dimensions = () type = integer intent = in -[biomass_burn_opt_in] - standard_name = control_for_smoke_biomass_burn - long_name = rrfs smoke biomass burning option +[drydep_opt_in] + standard_name = control_for_smoke_dry_deposition + long_name = rrfs smoke dry deposition option units = index dimensions = () type = integer intent = in -[drydep_opt_in] - standard_name = control_for_smoke_dry_deposition - long_name = rrfs smoke dry deposition option +[wetdep_ls_opt_in] + standard_name = control_for_smoke_wet_deposition + long_name = rrfs smoke large scale wet deposition option units = index dimensions = () type = integer intent = in +[wetdep_ls_alpha_in] + standard_name = alpha_for_ls_wet_depoistion + long_name = alpha paramter for ls wet deposition + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [do_plumerise_in] standard_name = do_smoke_plumerise long_name = rrfs smoke plumerise option @@ -618,10 +680,10 @@ intent = in [smoke_forecast_in] standard_name = do_smoke_forecast - long_name = flag for rrfs smoke forecast - units = flag + long_name = index for rrfs smoke forecast + units = index dimensions = () - type = logical + type = integer intent = in [aero_ind_fdb_in] standard_name = do_smoke_aerosol_indirect_feedback diff --git a/smoke/seas_data_mod.F90 b/physics/smoke/seas_data_mod.F90 similarity index 100% rename from smoke/seas_data_mod.F90 rename to physics/smoke/seas_data_mod.F90 diff --git a/smoke/seas_mod.F90 b/physics/smoke/seas_mod.F90 similarity index 98% rename from smoke/seas_mod.F90 rename to physics/smoke/seas_mod.F90 index 85c8611564..935b64513e 100755 --- a/smoke/seas_mod.F90 +++ b/physics/smoke/seas_mod.F90 @@ -13,7 +13,6 @@ module seas_mod implicit none - integer, parameter :: SEAS_OPT_DEFAULT = 1 integer, parameter :: CHEM_OPT_GOCART = 300 integer, parameter :: chem_opt = 300 @@ -22,13 +21,11 @@ module seas_mod private - public :: SEAS_OPT_DEFAULT - public :: gocart_seasalt_driver CONTAINS - subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & + subroutine gocart_seasalt_driver(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,pi, & seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & @@ -36,7 +33,7 @@ subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - INTEGER, INTENT(IN ) :: ktau,num_emis_seas,num_moist,num_chem, & + INTEGER, INTENT(IN ) :: 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 diff --git a/smoke/seas_ngac_mod.F90 b/physics/smoke/seas_ngac_mod.F90 similarity index 100% rename from smoke/seas_ngac_mod.F90 rename to physics/smoke/seas_ngac_mod.F90 diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index 0f4ad447e8..ff4d419ece 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,7 +1,5 @@ !>\file ugwp_driver_v0.F - module ugwp_driver_v0 - use cires_orowam2017 - contains + ! !===================================================================== ! @@ -1491,4 +1489,3 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, return end subroutine fv3_ugwp_solv2_v0 - end module ugwp_driver_v0 diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 0bcbc4f622..febad52ff3 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -38,8 +38,7 @@ module unified_ugwp ! use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run - use cires_ugwp_triggers - use ugwp_driver_v0 + use drag_suite, only: drag_suite_run implicit none diff --git a/smoke/dep_dry_gocart_mod.F90 b/smoke/dep_dry_gocart_mod.F90 deleted file mode 100755 index 9fb5edfd11..0000000000 --- a/smoke/dep_dry_gocart_mod.F90 +++ /dev/null @@ -1,302 +0,0 @@ -!>\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 - 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 deleted file mode 100755 index 9520d2897b..0000000000 --- a/smoke/dep_dry_mod.F90 +++ /dev/null @@ -1,303 +0,0 @@ -!>\file dep_dry_mod.F90 -!! This file is for the dry depostion driver. - -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 deleted file mode 100755 index 37a8189b55..0000000000 --- a/smoke/dep_simple_mod.F90 +++ /dev/null @@ -1,766 +0,0 @@ -!>\file dep_simple_mod.F90 -!! This file contains the Wesely dry deposition module. - -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 deleted file mode 100755 index d56b1b87ee..0000000000 --- a/smoke/dep_vertmx_mod.F90 +++ /dev/null @@ -1,212 +0,0 @@ -!>\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 - -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 deleted file mode 100755 index 3a7a186eac..0000000000 --- a/smoke/dep_wet_ls_mod.F90 +++ /dev/null @@ -1,562 +0,0 @@ -!>\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 - use rrfs_smoke_config -! 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, grav, & - 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, 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 ), & - 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 - 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.) cycle big_i_loop - 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 - exit - endif - end do - 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. - !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 - exit - end if - end do - - 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 - exit - end if - end do - - 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 - - end do big_i_loop ! 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/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 deleted file mode 100755 index cb9cc25e66..0000000000 --- a/smoke/rrfs_smoke_data.F90 +++ /dev/null @@ -1,651 +0,0 @@ -!>\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 - 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,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 .. -!-------------------------------------------------- - ! 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 - errmsg='number of land use classifications not correct ' - errflg=1 - return - END IF - IF (dep_seasons/=5) THEN - errmsg='number of dep_seasons not correct ' - errflg=1 - return - 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 deleted file mode 100644 index 1fd7a2d3fa..0000000000 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ /dev/null @@ -1,323 +0,0 @@ -!>\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 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_run - -contains - -!>\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, g, & - 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,g - - 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(:), 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(:,:,:), 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,g, & - 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, 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 - 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,g, & - 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,g - - !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 deleted file mode 100755 index 23c71fce8a..0000000000 --- a/smoke/rrfs_smoke_lsdep_wrapper.meta +++ /dev/null @@ -1,208 +0,0 @@ -[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_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 -[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 - 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_in_tracer_concentration_array - long_name = tracer index for smoke - units = index - dimensions = () - type = integer - intent = in -[ntdust] - standard_name = index_for_dust_in_tracer_concentration_array - 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 = control_for_smoke_wet_deposition - 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