diff --git a/.gitmodules b/.gitmodules index 8758980ec..24b9cf118 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,7 @@ [submodule "physics/rte-rrtmgp"] - path = physics/rte-rrtmgp + path = physics/Radiation/RRTMGP/rte-rrtmgp url = https://github.com/earth-system-radiation/rte-rrtmgp branch = main +[submodule "physics/Radiation/RRTMGP/rte-rrtmgp"] + path = physics/Radiation/RRTMGP/rte-rrtmgp + url = https://github.com/earth-system-radiation/rte-rrtmgp diff --git a/CMakeLists.txt b/CMakeLists.txt index 97591a2ee..ee708d4c4 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -79,37 +79,37 @@ get_filename_component(LOCAL_CURRENT_SOURCE_DIR ${FULL_PATH_TO_CMAKELISTS} DIREC #------------------------------------------------------------------------------ # List of files that need to be compiled without OpenMP -set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_byband.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/solar_variability/mo_solar_variability.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_heating_rates.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_bygpoint.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_compute_bc.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_sampling.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_config.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_source_functions.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_sw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_fluxes.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_lw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_util_array.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_kind.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_optical_props.F90) +set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_gas_optics.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_fluxes_byband.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/solar_variability/mo_solar_variability.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_heating_rates.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_fluxes_bygpoint.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/mo_compute_bc.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/cloud_optics/mo_cloud_sampling.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_config.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_source_functions.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_sw.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_fluxes.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_lw.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_util_array.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_rte_kind.F90 + ${LOCAL_CURRENT_SOURCE_DIR}/physics/Radiation/RRTMGP/rte-rrtmgp/rte/mo_optical_props.F90) # List of files that need to be compiled with different precision set(SCHEMES_DYNAMICS) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/fv_sat_adj.F90 IN_LIST SCHEMES) - list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/fv_sat_adj.F90) +if(${LOCAL_CURRENT_SOURCE_DIR}/physics/MP/GFDL/fv_sat_adj.F90 IN_LIST SCHEMES) + list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/MP/GFDL/fv_sat_adj.F90) endif() # Remove files that need to be compiled with different precision diff --git a/CODEOWNERS b/CODEOWNERS index 8f53a50bc..d55a200fc 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -196,6 +196,8 @@ physics/ysuvdif.* @Qingfu-Liu @WeiguoWang-NOAA physics/zhaocarr_gscond.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/zhaocarr_precpd.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_land.* @uturuncoglu @barlage + ######################################################################## # Lines starting with '#' are comments. diff --git a/physics/cu_c3_deep.F90 b/physics/CONV/C3/cu_c3_deep.F90 similarity index 99% rename from physics/cu_c3_deep.F90 rename to physics/CONV/C3/cu_c3_deep.F90 index 7092840c3..b7cd5f62d 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/CONV/C3/cu_c3_deep.F90 @@ -97,6 +97,9 @@ subroutine cu_c3_deep_run( & ,tmf & ! instantanious tendency from turbulence ,qmicro & ! instantanious tendency from microphysics ,forceqv_spechum & !instantanious tendency from dynamics + ,betascu & ! Tuning parameter for shallow clouds + ,betamcu & ! Tuning parameter for mid-level clouds + ,betadcu & ! Tuning parameter for deep clouds ,sigmain & ! input area fraction after advection ,sigmaout & ! updated prognostic area fraction ,z1 & ! terrain @@ -233,8 +236,8 @@ subroutine cu_c3_deep_run( & real(kind=kind_phys) & - ,intent (in ) :: & - dtime,ccnclean,fv,r_d + ,intent (in ) :: & + dtime,ccnclean,fv,r_d,betascu,betamcu,betadcu ! @@ -386,13 +389,16 @@ subroutine cu_c3_deep_run( & real(kind=kind_phys), dimension (its:ite) :: pefc real(kind=kind_phys) entdo,dp,subin,detdo,entup, & detup,subdown,entdoj,entupk,detupk,totmas + real(kind=kind_phys) :: & + sigmind,sigminm,sigmins + parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01) real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec !$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) integer :: jprnt,jmini,start_k22 logical :: keep_going,flg(its:ite),cnvflg(its:ite) - logical :: flag_shallow + logical :: flag_shallow,flag_mid !$acc declare create(flg) @@ -1988,7 +1994,11 @@ subroutine cu_c3_deep_run( & ! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then + flag_mid = .false. flag_shallow = .false. + if(imid.eq.1)then + flag_mid = .true. + endif do k=kts,ktf do i=its,itf del(i,k) = delp(i,k)*0.001 @@ -2003,9 +2013,9 @@ subroutine cu_c3_deep_run( & endif enddo call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & - del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & - forceqv_spechum,kbcon,ktop,cnvflg, & - sigmain,sigmaout,sigmab) + flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !$acc end kernels @@ -3147,7 +3157,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 ! pcrit,acrit,acritt integer, dimension (its:ite) :: kloc real(kind=kind_phys) :: & - a1,a_ave,xff0,xomg,gravinv!,aclim1,aclim2,aclim3,aclim4 + a1,a_ave,xff0,xomg,gravinv real(kind=kind_phys), dimension (its:ite) :: ens_adj !$acc declare create(kloc,ens_adj) diff --git a/physics/cu_c3_driver.F90 b/physics/CONV/C3/cu_c3_driver.F90 similarity index 97% rename from physics/cu_c3_driver.F90 rename to physics/CONV/C3/cu_c3_driver.F90 index 8592e08f9..c911ff5e4 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/CONV/C3/cu_c3_driver.F90 @@ -30,7 +30,8 @@ module cu_c3_driver !! \htmlinclude cu_c3_driver_init.html !! subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & - imfdeepcnv_c3,mpirank, mpiroot, errmsg, errflg) + imfdeepcnv_c3,progsigma, cnx, mpirank, mpiroot, & + errmsg, errflg) implicit none @@ -38,6 +39,8 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & integer, intent(in) :: imfdeepcnv, imfdeepcnv_c3 integer, intent(in) :: mpirank integer, intent(in) :: mpiroot + integer, intent(in) :: cnx + logical, intent(inout) :: progsigma character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -45,6 +48,13 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & errmsg = '' errflg = 0 + if(progsigma)then + if(cnx < 384)then + progsigma=.false. + write(*,*)'Forcing prognostic closure to .false. due to coarse resolution' + endif + endif + end subroutine cu_c3_driver_init ! @@ -60,7 +70,8 @@ end subroutine cu_c3_driver_init subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & - qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + betascu,betamcu,betadcu,qv_spechum,t,cld1d,us,vs,t2di,w, & + qv2di_spechum,p2di,psuri, & hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,& pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & @@ -96,10 +107,10 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & - do_ca,progsigma - real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v + do_ca + real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v,betascu,betamcu,betadcu logical, intent(in ) :: ldiag3d - + logical, intent(in ) :: progsigma real(kind=kind_phys), intent(inout) :: dtend(:,:,:) !$acc declare copy(dtend) integer, intent(in) :: dtidx(:,:), & @@ -587,7 +598,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& hfx(i)=hfx2(i)*cp*rhoi(i,1) qfx(i)=qfx2(i)*xlv*rhoi(i,1) dx(i) = sqrt(garea(i)) - enddo + enddo do i=its,itf do k=kts,kpbli(i) @@ -669,7 +680,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & ! Prog closure flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma,dx, & + forceqv_spechum,betascu,betamcu,betadcu,sigmain, & + sigmaout,progsigma,dx, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables @@ -714,6 +726,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,tmfq & ,qmicro & ,forceqv_spechum & + ,betascu & + ,betamcu & + ,betadcu & ,sigmain & ,sigmaout & ,ter11 & @@ -805,6 +820,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,tmfq & ,qmicro & ,forceqv_spechum & + ,betascu & + ,betamcu & + ,betadcu & ,sigmain & ,sigmaout & ,ter11 & diff --git a/physics/cu_c3_driver.meta b/physics/CONV/C3/cu_c3_driver.meta similarity index 94% rename from physics/cu_c3_driver.meta rename to physics/CONV/C3/cu_c3_driver.meta index 999b5c2bc..5677cdd32 100644 --- a/physics/cu_c3_driver.meta +++ b/physics/CONV/C3/cu_c3_driver.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = cu_c3_driver type = scheme - dependencies = cu_c3_deep.F90,cu_c3_sh.F90,machine.F,physcons.F90,progsigma_calc.f90 + dependencies = ../../hooks/machine.F + dependencies = cu_c3_deep.F90,cu_c3_sh.F90,../progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -49,6 +50,20 @@ 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 = inout +[cnx] + standard_name = number_of_x_points_for_current_cubed_sphere_tile + long_name = number of points in x direction for this cubed sphere face + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -244,6 +259,29 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in [phil] standard_name = geopotential long_name = layer geopotential diff --git a/physics/cu_c3_driver_post.F90 b/physics/CONV/C3/cu_c3_driver_post.F90 similarity index 100% rename from physics/cu_c3_driver_post.F90 rename to physics/CONV/C3/cu_c3_driver_post.F90 diff --git a/physics/cu_c3_driver_post.meta b/physics/CONV/C3/cu_c3_driver_post.meta similarity index 98% rename from physics/cu_c3_driver_post.meta rename to physics/CONV/C3/cu_c3_driver_post.meta index c53972f09..78dca2ed4 100644 --- a/physics/cu_c3_driver_post.meta +++ b/physics/CONV/C3/cu_c3_driver_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_c3_driver_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_c3_driver_pre.F90 b/physics/CONV/C3/cu_c3_driver_pre.F90 similarity index 100% rename from physics/cu_c3_driver_pre.F90 rename to physics/CONV/C3/cu_c3_driver_pre.F90 diff --git a/physics/cu_c3_driver_pre.meta b/physics/CONV/C3/cu_c3_driver_pre.meta similarity index 98% rename from physics/cu_c3_driver_pre.meta rename to physics/CONV/C3/cu_c3_driver_pre.meta index c018bee9f..a022cf743 100644 --- a/physics/cu_c3_driver_pre.meta +++ b/physics/CONV/C3/cu_c3_driver_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_c3_driver_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_c3_sh.F90 b/physics/CONV/C3/cu_c3_sh.F90 similarity index 98% rename from physics/cu_c3_sh.F90 rename to physics/CONV/C3/cu_c3_sh.F90 index a79e1dfcf..736292092 100644 --- a/physics/cu_c3_sh.F90 +++ b/physics/CONV/C3/cu_c3_sh.F90 @@ -68,7 +68,8 @@ subroutine cu_c3_sh_run ( & hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma,dx, & + forceqv_spechum,betascu,betamcu,betadcu,sigmain,& + sigmaout,progsigma,dx, & outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables ! @@ -131,7 +132,7 @@ subroutine cu_c3_sh_run ( & real(kind=kind_phys) & ,intent (in ) :: & - dtime,tcrit,fv,r_d + dtime,tcrit,fv,r_d,betascu,betamcu,betadcu !$acc declare sigmaout real(kind=kind_phys), dimension (its:,kts:) & ,intent (out) :: & @@ -234,15 +235,18 @@ subroutine cu_c3_sh_run ( & !$acc cap_max_increment,lambau, & !$acc kstabi,xland1,kbmax,ktopx) - logical :: flag_shallow + logical :: flag_shallow,flag_mid logical, dimension(its:ite) :: cnvflg integer :: & kstart,i,k,ki - real(kind=kind_phys) :: & + real(kind=kind_phys) :: & dz,mbdt,zkbmax, & cap_maxs,trash,trash2,frh,el2orc,gravinv - real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + real(kind=kind_phys) :: & + sigmind,sigminm,sigmins + parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01) real(kind=kind_phys) xff_shal(3),blqe,xkshal character*50 :: ierrc(its:) @@ -672,13 +676,13 @@ subroutine cu_c3_sh_run ( & dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water c1d(i,k)=c1_shal! 0. !.02*up_massdetr(i,k-1) + clw_all(i,k)=max(0._kind_phys,qco(i,k)-trash) qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 qrco(i,k)=0. !c1d(i,k)=0. endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) - clw_all(i,k)=qco(i,k)-trash !LB total cloud before rain and detrain ! cloud water vapor qco (i,k)= trash+qrco(i,k) @@ -960,6 +964,7 @@ subroutine cu_c3_sh_run ( & ! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then flag_shallow = .true. + flag_mid = .false. do k=kts,ktf do i=its,itf del(i,k) = delp(i,k)*0.001 @@ -974,9 +979,9 @@ subroutine cu_c3_sh_run ( & endif enddo call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & - del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & - forceqv_spechum,kbcon,ktop,cnvflg, & - sigmain,sigmaout,sigmab) + flag_mid,del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif diff --git a/physics/cs_conv.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv.F90 similarity index 100% rename from physics/cs_conv.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv.F90 diff --git a/physics/cs_conv.meta b/physics/CONV/Chikira_Sugiyama/cs_conv.meta similarity index 99% rename from physics/cs_conv.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv.meta index fae1c91fe..49e460ed6 100644 --- a/physics/cs_conv.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = cs_conv type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/cs_conv_aw_adj.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.F90 similarity index 100% rename from physics/cs_conv_aw_adj.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.F90 diff --git a/physics/cs_conv_aw_adj.meta b/physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.meta similarity index 99% rename from physics/cs_conv_aw_adj.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.meta index 0dada0fd5..54350dbac 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv_aw_adj.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cs_conv_aw_adj type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cs_conv_post.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv_post.F90 similarity index 100% rename from physics/cs_conv_post.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv_post.F90 diff --git a/physics/cs_conv_post.meta b/physics/CONV/Chikira_Sugiyama/cs_conv_post.meta similarity index 97% rename from physics/cs_conv_post.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv_post.meta index 116ffbef4..75de3fca7 100644 --- a/physics/cs_conv_post.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = cs_conv_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cs_conv_pre.F90 b/physics/CONV/Chikira_Sugiyama/cs_conv_pre.F90 similarity index 100% rename from physics/cs_conv_pre.F90 rename to physics/CONV/Chikira_Sugiyama/cs_conv_pre.F90 diff --git a/physics/cs_conv_pre.meta b/physics/CONV/Chikira_Sugiyama/cs_conv_pre.meta similarity index 99% rename from physics/cs_conv_pre.meta rename to physics/CONV/Chikira_Sugiyama/cs_conv_pre.meta index 2decd5f8b..7ce80496b 100644 --- a/physics/cs_conv_pre.meta +++ b/physics/CONV/Chikira_Sugiyama/cs_conv_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cs_conv_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_gf_deep.F90 b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 similarity index 95% rename from physics/cu_gf_deep.F90 rename to physics/CONV/Grell_Freitas/cu_gf_deep.F90 index 0d1fc68c7..8a2c73600 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 @@ -3,6 +3,7 @@ module cu_gf_deep use machine , only : kind_phys + use physcons, only : qamin real(kind=kind_phys), parameter::g=9.81 real(kind=kind_phys), parameter:: cp=1004. real(kind=kind_phys), parameter:: xlv=2.5e6 @@ -124,6 +125,11 @@ subroutine cu_gf_deep_run( & ,frh_out & ! fractional coverage ,ierr & ! ierr flags are error flags, used for debugging ,ierrc & ! the following should be set to zero if not available + ,nchem & + ,fscav & + ,chem3d & + ,wetdpc_deep & + ,do_smoke_transport & ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist @@ -136,15 +142,15 @@ subroutine cu_gf_deep_run( & !! betwee -1 and +1 ,do_capsuppress,cap_suppress_j & ! ,k22 & ! - ,jmin,tropics) ! + ,jmin,kdt,tropics) ! implicit none integer & ,intent (in ) :: & - nranflag,itf,ktf,its,ite, kts,kte,ipr,imid + nranflag,itf,ktf,its,ite, kts,kte,ipr,imid,kdt integer, intent (in ) :: & - ichoice + ichoice,nchem real(kind=kind_phys), dimension (its:ite,4) & ,intent (in ) :: rand_clos real(kind=kind_phys), dimension (its:ite) & @@ -163,17 +169,17 @@ subroutine cu_gf_deep_run( & ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & cnvwt,outu,outv,outt,outq,outqc,cupclw - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & frh_out - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & pre,xmb_out !$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & hfx,qfx,xmbm_in,xmbs_in !$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) @@ -190,29 +196,36 @@ subroutine cu_gf_deep_run( & ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off ! convection for this call only and at that particular gridpoint ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & dhdt,rho,t,po,us,vs,tn !$acc declare copyin(dhdt,rho,t,po,us,vs,tn) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & omeg !$acc declare copy(omeg) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo,zuo,zdo,zdm !$acc declare copy(q,qo,zuo,zdo,zdm) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & dx,z1,psur,xland !$acc declare copyin(dx,z1,psur,xland) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & mconv,ccn !$acc declare copy(mconv,ccn) - - - real(kind=kind_phys) & + real(kind=kind_phys), dimension (:,:,:) & + ,intent (inout) :: & + chem3d + logical, intent (in) :: do_smoke_transport + real(kind=kind_phys), dimension (:,:) & + , intent (out) :: wetdpc_deep + real(kind=kind_phys), intent (in) :: fscav(:) +!$acc declare copy(chem3d) copyout(wetdpc_deep) copyin(fscav) + + real(kind=kind_phys) & ,intent (in ) :: & dtime,ccnclean @@ -220,11 +233,11 @@ subroutine cu_gf_deep_run( & ! ! local ensemble dependent variables in this routine ! - real(kind=kind_phys), dimension (its:ite,1) :: & + real(kind=kind_phys), dimension (its:ite,1) :: & xaa0_ens - real(kind=kind_phys), dimension (its:ite,1) :: & + real(kind=kind_phys), dimension (its:ite,1) :: & edtc - real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & + real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens !$acc declare create(xaa0_ens,edtc,dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens) ! @@ -292,8 +305,20 @@ subroutine cu_gf_deep_run( & ! xmb = total base mass flux ! hc = cloud moist static energy ! hkb = moist static energy at originating level - - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + real(kind=kind_phys), dimension (its:ite,kts:kte,nchem) :: & + chem + real(kind=kind_phys), dimension (its:ite,kts:kte,nchem) :: & + chem_cup,chem_up,chem_down,dellac,dellac2,chem_c,chem_pw,chem_pwd + real(kind=kind_phys), dimension (its:ite,nchem) :: & + chem_pwav,chem_psum + real(kind=kind_phys):: dtime_max,sum1,sum2 + real(kind=kind_phys), dimension (kts:kte) :: trac,trcflx_in,trcflx_out,trc,trco + real(kind=kind_phys), dimension (its:ite,kts:kte) :: pwdper, massflx + integer :: nv +!$acc declare create(chem,chem_cup,chem_up,chem_down,dellac,dellac2,chem_c,chem_pw,chem_pwd, & +!$acc chem_pwav,chem_psum,pwdper,massflux) + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & @@ -330,13 +355,13 @@ subroutine cu_gf_deep_run( & ! xaa0 = cloud work function with cloud effects (ensemble dependent) ! edt = epsilon - real(kind=kind_phys), dimension (its:ite) :: & - edt,edto,edtm,aa1,aa0,xaa0,hkb, & + real(kind=kind_phys), dimension (its:ite) :: & + edt,edto,edtm,aa1,aa0,xaa0,hkb, & hkbo,xhkb, & xmb,pwavo,ccnloss, & pwevo,bu,bud,cap_max, & cap_max_increment,closure_n,psum,psumh,sig,sigd - real(kind=kind_phys), dimension (its:ite) :: & + real(kind=kind_phys), dimension (its:ite) :: & axx,edtmax,edtmin,entr_rate integer, dimension (its:ite) :: & kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & @@ -372,10 +397,10 @@ subroutine cu_gf_deep_run( & character*50 :: ierrc(its:ite) character*4 :: cumulus - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentr,up_massdetr,c1d & ,up_massentro,up_massdetro,dd_massentro,dd_massdetro - real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentru,up_massdetru,dd_massentru,dd_massdetru !$acc declare create(up_massentr,up_massdetr,c1d,up_massentro,up_massdetro,dd_massentro,dd_massdetro, & !$acc up_massentru,up_massdetru,dd_massentru,dd_massdetru) @@ -401,7 +426,8 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB -!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: c0t3d ! hli for smoke/dust wet scavenging +!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0,c0t3d) ! rainevap from sas real(kind=kind_phys) zuh2(40) @@ -565,6 +591,7 @@ subroutine cu_gf_deep_run( & sig(i)=(1.-frh)**2 !frh_out(i) = frh if(forcing(i,7).eq.0.)sig(i)=1. + if(kdt.le.(3600./dtime))sig(i)=1. frh_out(i) = frh*sig(i) enddo !$acc end kernels @@ -1058,14 +1085,14 @@ subroutine cu_gf_deep_run( & if(imid.eq.1)then call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0,c0t3d, & zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) else call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & - qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0,c0t3d, & zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) @@ -2013,6 +2040,186 @@ subroutine cu_gf_deep_run( & kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) +! +! +!>- atmospheric composition tracers +! +!> ## Determine whether to perform aerosol transport + if (do_smoke_transport .and. nchem > 0) then +! +! initialize tracers if they exist +! + chem (:,:,:) = 0. +!$acc kernels + do nv = 1,nchem + do k = 1, ktf + do i = 1, itf + chem(i,k,nv) = max(qamin, chem3d(i,k,nv)) + enddo + enddo + enddo + + wetdpc_deep = 0. + + chem_pwav(:,:) = 0. + chem_psum(:,:) = 0. + chem_pw (:,:,:) = 0. + chem_pwd (:,:,:) = 0. + pwdper (:,:) = 0. + chem_down(:,:,:) = 0. + chem_up (:,:,:) = 0. + chem_c (:,:,:) = 0. + chem_cup (:,:,:) = 0. + + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,jmin(i) + if(pwavo(i).ne.0.) pwdper(i,k)=-edtc(i,1)*pwdo(i,k)/pwavo(i) + enddo + pwdper(i,:)=0. + do nv=1,nchem + do k=kts+1,ktf + chem_cup(i,k,nv)=.5*(chem(i,k-1,nv)+chem(i,k,nv)) + enddo + chem_cup(i,kts,nv)=chem(i,kts,nv) +! +! in updraft +! + do k=1,k22(i) + chem_up(i,k,nv)=chem_cup(i,k,nv) + enddo + do k=k22(i)+1,ktop(i) + chem_up(i,k,nv)=(chem_up(i,k-1,nv)*zuo(i,k-1) & + -.5*up_massdetr(i,k-1)*chem_up(i,k-1,nv)+ & + up_massentr(i,k-1)*chem(i,k-1,nv)) / & + (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + chem_c(i,k,nv)=fscav(nv)*chem_up(i,k,nv) + dz=zo_cup(i,K)-zo_cup(i,K-1) + trash2=chem_up(i,k,nv)-chem_c(i,k,nv) + trash=chem_c(i,k,nv)/(1.+c0t3d(i,k)*dz) + chem_pw=c0t3d(i,k)*dz*trash*zuo(i,k) + chem_up(i,k,nv)=trash2+trash + chem_pwav(i,nv)=chem_pwav(i,nv)+chem_pw(i,k,nv)! *g/dp + enddo + do k=ktop(i)+1,ktf + chem_up(i,k,nv)=chem_cup(i,k,nv) + enddo +! +! in downdraft +! + chem_down(i,jmin(i)+1,nv)=chem_cup(i,jmin(i)+1,nv) + chem_psum(i,nv)=0. + do ki=jmin(i),2,-1 + dp=100.*(po_cup(i,ki)-po_cup(i,ki+1)) + chem_down(i,ki,nv)=(chem_down(i,ki+1,nv)*zdo(i,ki+1) & + -.5_kind_phys*dd_massdetro(i,ki)*chem_down(i,ki+1,nv)+ & + dd_massentro(i,ki)*chem(i,ki,nv)) / & + (zdo(i,ki+1)-.5_kind_phys*dd_massdetro(i,ki)+dd_massentro(i,ki)) + chem_down(i,ki,nv)=chem_down(i,ki,nv)+pwdper(i,ki)*chem_pwav(i,nv) + chem_pwd(i,ki,nv)=max(0._kind_phys,pwdper(i,ki)*chem_pwav(i,nv)) + enddo +! total wet deposition + do k=1,ktf-1 + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + chem_psum(i,nv)=chem_psum(i,nv)+chem_pw(i,k,nv)*g !/dp + enddo + chem_psum(i,nv)=chem_psum(i,nv)*xmb(i)*dtime +! + enddo ! nchem + endif ! ierr=0 + enddo ! i + + dellac(:,:,:)=0. + + do nv=1,nchem + do i=its,itf + if(ierr(i).eq.0)then + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellac(i,1,nv)=dellac(i,1,nv)+(edto(i)*zdo(i,2)*chem_down(i,2,nv))*g/dp*xmb(i) + if(k22(i).eq.2)then + entupk=zuo(i,2) + dellac(i,1,nv)=dellac(i,1,nv)-entupk*chem_cup(i,2,nv)*g/dp*xmb(i) + endif + do k=kts+1,ktop(i)-1 + detup=0. + detdo=0. + entup=0. + entdo=0. + entdoj=0. + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + ! entrainment/detrainment for updraft + entdo=edto(i)*dd_massentro(i,k)*chem(i,k,nv) + detdo=edto(i)*dd_massdetro(i,k)*.5*(chem_down(i,k+1,nv)+chem_down(i,k,nv)) + entup=up_massentro(i,k)*chem(i,k,nv) + detup=up_massdetro(i,k)*.5*(chem_up(i,k+1,nv)+chem_up(i,k,nv)) + ! special levels + if(k == k22(i)-1) then + entup=zuo(i,k+1)*chem_cup(i,k+1,nv) + detup=0. + endif + if(k.eq.jmin(i))entdoj=edto(i)*zdo(i,k)*chem_cup(i,k,nv) +! mass budget + dellac(i,k,nv) =dellac(i,k,nv) + (detup+detdo-entdo-entup-entdoj)*g/dp*xmb(i) + enddo + dellac(i,ktop(i),nv)=zuo(i,ktop(i))*chem_up(i,ktop(i),nv)*g/dp*xmb(i) + endif ! ierr + enddo ! i + enddo ! nchem loop + +! fct for subsidence + dellac2(:,:,:)=0. + massflx(:,:)=0. + do nv=1,nchem +!$acc loop private(trcflx_in) + do i=its,itf + if(ierr(i).eq.0)then + trcflx_in(:)=0. + dtime_max=dtime + +! initialize fct routine + do k=kts,ktop(i) + dp=100._kind_phys*(po_cup(i,k)-po_cup(i,k+1)) + dtime_max=min(dtime_max,.5_kind_phys*dp) + massflx(i,k)=-xmb(i)*(zuo(i,k)-edto(i)*zdo(i,k)) + trcflx_in(k)=massflx(i,k)*chem_cup(i,k,nv) + enddo + trcflx_in(1)=0. + massflx(i,1)=0. + call fct1d3(ktop(i),kte,dtime_max,po_cup(i,:),chem(i,:,nv),massflx(i,:), & + trcflx_in,dellac2(i,:,nv),g) + do k=kts,ktop(i) + trash=chem (i,k,nv) + chem (i,k,nv)=chem (i,k,nv) + (dellac(i,k,nv)+dellac2(i,k,nv))*dtime + if(chem(i,k,nv).lt.qamin)then + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + wetdpc_deep(i,nv)=wetdpc_deep(i,nv)+(qamin-chem(i,k,nv))*dp/g/dtime + chem(i,k,nv)=qamin + endif + enddo + endif + + enddo ! i + enddo ! nchem loop + +!> - Store aerosol concentrations if present + do nv = 1, nchem + do i = 1, itf + do k = 1, ktf + if(ierr(i).eq.0) then + if (k <= ktop(i)) then + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + wetdpc_deep(i,nv)=wetdpc_deep(i,nv) + ((chem3d(i,k,nv)-chem(i,k,nv))*dp/(g*dtime)) + chem3d(i,k,nv) = chem(i,k,nv) + endif + endif + enddo + wetdpc_deep(i,nv)=max(wetdpc_deep(i,nv),qamin) + enddo + enddo +!$acc end kernels + + endif ! nchem > 0 + k=1 !$acc kernels do i=its,itf @@ -4101,7 +4308,7 @@ end subroutine cup_output_ens_3d !> Calculates moisture properties of the updraft. subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & p_cup,kbcon,ktop,dby,clw_all,xland1, & - q,gamma_cup,zu,qes_cup,k22,qe_cup,c0, & + q,gamma_cup,zu,qes_cup,k22,qe_cup,c0,c0t3d, & zqexec,ccn,ccnclean,rho,c1d,t,autoconv, & up_massentr,up_massdetr,psum,psumh, & itest,itf,ktf, & @@ -4137,11 +4344,13 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & zqexec,c0 + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: c0t3d ! entr= entrainment rate integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop,k22,xland1 !$acc declare copyin(p_cup,rho,q,zu,gamma_cup,qe_cup,up_massentr,up_massdetr,dby,qes_cup,z_cup,zqexec,c0,kbcon,ktop,k22,xland1) +!$acc declare copy(c0t3d) real(kind=kind_phys), intent (in ) :: & ! HCB ccnclean ! @@ -4218,6 +4427,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & c0_iceconv=0.01 c1d_b=c1d bdsp(:)=bdispm +!$acc kernels + c0t3d = 0. +!$acc end kernels ! !--- no precip for small clouds @@ -4288,6 +4500,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & else c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif + c0t3d(i,k)=c0t qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & up_massentr(i,k-1)*q(i,k-1)) / & (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) @@ -4320,6 +4533,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif if(is_mid)c0t=0.004 + c0t3d(i,k)=c0t if(autoconv .gt.1) c0t=c0(i) denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) diff --git a/physics/cu_gf_driver.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 similarity index 97% rename from physics/cu_gf_driver.F90 rename to physics/CONV/Grell_Freitas/cu_gf_driver.F90 index d85b7ac52..54a23ca74 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 @@ -67,8 +67,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & maxupmf,maxMF,do_mynnedmf,ichoice_in,ichoicem_in,ichoice_s_in, & - spp_cu_deep,spp_wts_cu_deep, & - errmsg,errflg) + spp_cu_deep,spp_wts_cu_deep,nchem,chem3d,fscav,wetdpc_deep, & + do_smoke_transport,kdt,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -86,7 +86,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& & spp_wts_cu_deep real(kind=kind_phys) :: spp_wts_cu_deep_tmp - logical, intent(in) :: do_cap_suppress + logical, intent(in) :: do_cap_suppress, do_smoke_transport real(kind=kind_phys), parameter :: aodc0=0.14 real(kind=kind_phys), parameter :: aodreturn=30. real(kind=kind_phys) :: dts,fpi,fp @@ -95,7 +95,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: ishallow_g3 ! depend on imfshalcnv !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte - integer, intent(in ) :: im,km,ntracer + integer, intent(in ) :: im,km,ntracer,nchem,kdt integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend @@ -154,7 +154,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, intent(in ) :: imfshalcnv integer, dimension(:), intent(inout) :: cactiv,cactiv_m -!$acc declare copy(cactiv,cactiv_m) + real(kind_phys), dimension(:), intent(in) :: fscav +!$acc declare copyin(fscav) + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind_phys), dimension(:,:), intent(inout) :: wetdpc_deep +!$acc declare copy(cactiv,cactiv_m,chem3d,wetdpc_deep) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -179,19 +183,20 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension (im) :: tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi real(kind=kind_phys), dimension (im) :: pret,prets,pretm,hexec real(kind=kind_phys), dimension (im,10) :: forcing,forcing2 + real(kind=kind_phys), dimension (im,nchem) :: wetdpc_mid integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm integer, dimension (im) :: kbconm,ktopm,k22m !$acc declare create(k22_shallow,kbcon_shallow,ktop_shallow,rand_mom,rand_vmas, & -!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd, & +!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd,wetdpc_mid, & !$acc outt,outq,outqc,phh,subm,cupclw,cupclws, & !$acc dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm, & !$acc outts,outqs,outqcs,outu,outv,outus,outvs, & !$acc outtm,outqm,outqcm,submm,cupclwm, & !$acc cnvwt,cnvwts,cnvwtm,hco,hcdo,zdo,zdd,hcom,hcdom,zdom, & !$acc tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi, & -!$acc pret,prets,pretm,hexec,forcing,forcing2, & +!$acc pret,prets,pretm,hexec,forcing,forcing2,wetdpc_mid, & !$acc kbcon, ktop,ierr,ierrs,ierrm,kpbli, & !$acc k22s,kbcons,ktops,k22,jmin,jminm,kbconm,ktopm,k22m) @@ -743,6 +748,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,frhm & ,ierrm & ,ierrcm & + ,nchem & + ,fscav & + ,chem3d & + ,wetdpc_mid & + ,do_smoke_transport & ! the following should be set to zero if not available ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist @@ -756,7 +766,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! betwee -1 and +1 ,do_cap_suppress_here,cap_suppress_j & ,k22m & - ,jminm,tropics) + ,jminm,kdt,tropics) !$acc kernels do i=its,itf do k=kts,ktf @@ -825,6 +835,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,frhd & ,ierr & ,ierrc & + ,nchem & + ,fscav & + ,chem3d & + ,wetdpc_deep & + ,do_smoke_transport & ! the following should be set to zero if not available ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist @@ -838,7 +853,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! betwee -1 and +1 ,do_cap_suppress_here,cap_suppress_j & ,k22 & - ,jmin,tropics) + ,jmin,kdt,tropics) jpr=0 ipr=0 !$acc kernels diff --git a/physics/cu_gf_driver.meta b/physics/CONV/Grell_Freitas/cu_gf_driver.meta similarity index 93% rename from physics/cu_gf_driver.meta rename to physics/CONV/Grell_Freitas/cu_gf_driver.meta index 08e9de201..d0b661fd8 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = cu_gf_driver type = scheme - dependencies = cu_gf_deep.F90,cu_gf_sh.F90,machine.F,physcons.F90 + dependencies = ../../hooks/machine.F + dependencies = cu_gf_deep.F90,cu_gf_sh.F90 ######################################################################## [ccpp-arg-table] @@ -612,6 +613,51 @@ dimensions = () type = integer intent = in +[nchem] + standard_name = number_of_chemical_species_vertically_mixed + long_name = number of chemical species vertically mixed + units = count + dimensions = () + type = integer + intent = in +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout +[fscav] + standard_name = smoke_dust_conv_wet_coef + long_name = smoke dust convetive wet scavanging coefficents + units = none + dimensions = (3) + type = real + kind = kind_phys + intent = in +[do_smoke_transport] + standard_name = do_smoke_conv_transport + long_name = flag for rrfs smoke convective transport + units = flag + dimensions = () + type = logical + intent = in +[wetdpc_deep] + standard_name = conv_wet_deposition_smoke_dust + long_name = convective wet removal of smoke and dust + units = kg kg-1 + dimensions = (horizontal_loop_extent,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_gf_driver_post.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver_post.F90 similarity index 61% rename from physics/cu_gf_driver_post.F90 rename to physics/CONV/Grell_Freitas/cu_gf_driver_post.F90 index 5adf3ac42..6ed1321bc 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_post.F90 @@ -15,7 +15,7 @@ module cu_gf_driver_post !> \section arg_table_cu_gf_driver_post_run Argument Table !! \htmlinclude cu_gf_driver_post_run.html !! - subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m,dt, garea, raincv, maxupmf, refl_10cm, errmsg, errflg) + subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, rrfs_sd, ntsmoke, ntdust, ntcoarsepm, chem3d, gq0, errmsg, errflg) use machine, only: kind_phys @@ -25,25 +25,20 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m integer, intent(in) :: im, km real(kind_phys), intent(in) :: t(:,:) real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), dimension(:),intent(in) :: garea real(kind_phys), intent(out) :: prevst(:,:) real(kind_phys), intent(out) :: prevsq(:,:) integer, intent(in) :: cactiv(:) integer, intent(in) :: cactiv_m(:) real(kind_phys), intent(out) :: conv_act(:) real(kind_phys), intent(out) :: conv_act_m(:) - ! for Radar reflectivity - real(kind_phys), intent(in) :: dt - real(kind_phys), intent(in) :: raincv(:), maxupmf(:) - real(kind_phys), intent(inout) :: refl_10cm(:,:) + logical, intent(in) :: rrfs_sd + integer, intent(in) :: ntsmoke, ntdust, ntcoarsepm + real(kind_phys), intent(inout) :: chem3d(:,:,:), gq0(:,:,:) character(len=*), intent(out) :: errmsg -!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m,chem3d,gq0) integer, intent(out) :: errflg ! Local variables - real(kind_phys), parameter :: dbzmin=-10.0 - real(kind_phys) :: cuprate - real(kind_phys) :: ze, ze_conv, dbz_sum integer :: i, k ! Initialize CCPP error handling variables @@ -65,21 +60,13 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m else conv_act_m(i)=0.0 endif - ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) - ze = 0.0 - ze_conv = 0.0 - dbz_sum = 0.0 - cuprate = 1.e3*raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) - if(cuprate .lt. 0.05) cuprate=0. - ze_conv = 300.0 * cuprate**1.5 - if (maxupmf(i).gt.0.1 .and. cuprate.gt.0.) then - do k = 1, km - ze = 10._kind_phys ** (0.1 * refl_10cm(i,k)) - dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) - refl_10cm(i,k) = dbz_sum - enddo - endif enddo + + if (rrfs_sd) then + gq0(:,:,ntsmoke ) = chem3d(:,:,1) + gq0(:,:,ntdust ) = chem3d(:,:,2) + gq0(:,:,ntcoarsepm) = chem3d(:,:,3) + endif !$acc end kernels end subroutine cu_gf_driver_post_run diff --git a/physics/cu_gf_driver_post.meta b/physics/CONV/Grell_Freitas/cu_gf_driver_post.meta similarity index 70% rename from physics/cu_gf_driver_post.meta rename to physics/CONV/Grell_Freitas/cu_gf_driver_post.meta index 48e762cb4..478d48987 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_gf_driver_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -83,46 +83,34 @@ type = real kind = kind_phys intent = out -[dt] - standard_name = timestep_for_physics - long_name = physics time step - units = s +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection + units = flag dimensions = () - type = real - kind = kind_phys + type = logical intent = in -[garea] - standard_name = cell_area - long_name = grid cell area - units = m2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer intent = in -[raincv] - standard_name = lwe_thickness_of_deep_convective_precipitation_amount - long_name = deep convective rainfall amount on physics timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer intent = in -[maxupmf] - standard_name = maximum_convective_updraft_mass_flux - long_name = maximum convective updraft mass flux within a column - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys +[ntcoarsepm] + standard_name = index_for_coarse_particulate_matter_in_tracer_concentration_array + long_name = tracer index for coarse particulate matter + units = index + dimensions = () + type = integer intent = in -[refl_10cm] - standard_name = radar_reflectivity_10cm - long_name = instantaneous refl_10cm - units = dBZ - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -131,6 +119,22 @@ type = character kind = len=* intent = out +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout [errflg] standard_name = ccpp_error_code long_name = error code for error handling in CCPP diff --git a/physics/cu_gf_driver_pre.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.F90 similarity index 83% rename from physics/cu_gf_driver_pre.F90 rename to physics/CONV/Grell_Freitas/cu_gf_driver_pre.F90 index 98cc76b95..7ff66be21 100644 --- a/physics/cu_gf_driver_pre.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.F90 @@ -17,6 +17,7 @@ module cu_gf_driver_pre !! subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & + rrfs_sd, ntsmoke, ntdust, ntcoarsepm, chem3d, gq0, & errmsg, errflg) use machine, only: kind_phys @@ -25,6 +26,7 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, logical, intent(in) :: flag_init logical, intent(in) :: flag_restart + logical, intent(in) :: rrfs_sd integer, intent(in) :: kdt real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: dtp @@ -37,10 +39,12 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, real(kind_phys), intent(out) :: forceq(:,:) integer, intent(out) :: cactiv(:) integer, intent(out) :: cactiv_m(:) + integer, intent(in) :: ntsmoke, ntdust, ntcoarsepm !$acc declare copyout(forcet,forceq,cactiv,cactiv_m) real(kind_phys), intent(in) :: conv_act(:) real(kind_phys), intent(in) :: conv_act_m(:) -!$acc declare copyin(conv_act,conv_act_m) + real(kind_phys), intent(inout) :: chem3d(:,:,:), gq0(:,:,:) +!$acc declare copyin(conv_act,conv_act_m) copy(chem3d,gq0) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -77,6 +81,12 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, !$acc kernels cactiv(:)=nint(conv_act(:)) cactiv_m(:)=nint(conv_act_m(:)) + + if (rrfs_sd) then + chem3d(:,:,1) = gq0(:,:,ntsmoke) + chem3d(:,:,2) = gq0(:,:,ntdust) + chem3d(:,:,3) = gq0(:,:,ntcoarsepm) + endif !$acc end kernels end subroutine cu_gf_driver_pre_run diff --git a/physics/cu_gf_driver_pre.meta b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.meta similarity index 73% rename from physics/cu_gf_driver_pre.meta rename to physics/CONV/Grell_Freitas/cu_gf_driver_pre.meta index 7fd66d19b..ff22f1583 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_gf_driver_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -122,6 +122,50 @@ type = real kind = kind_phys intent = in +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection + units = flag + dimensions = () + type = logical + 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 +[ntcoarsepm] + standard_name = index_for_coarse_particulate_matter_in_tracer_concentration_array + long_name = tracer index for coarse particulate matter + units = index + dimensions = () + type = integer + intent = in +[chem3d] + standard_name = chem3d_mynn_pbl_transport + long_name = mynn pbl transport of smoke and dust + units = various + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_gf_sh.F90 b/physics/CONV/Grell_Freitas/cu_gf_sh.F90 similarity index 100% rename from physics/cu_gf_sh.F90 rename to physics/CONV/Grell_Freitas/cu_gf_sh.F90 diff --git a/physics/rascnv.F90 b/physics/CONV/RAS/rascnv.F90 similarity index 100% rename from physics/rascnv.F90 rename to physics/CONV/RAS/rascnv.F90 diff --git a/physics/rascnv.meta b/physics/CONV/RAS/rascnv.meta similarity index 99% rename from physics/rascnv.meta rename to physics/CONV/RAS/rascnv.meta index 5285c830f..f5a707ded 100644 --- a/physics/rascnv.meta +++ b/physics/CONV/RAS/rascnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rascnv type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/samfaerosols.F b/physics/CONV/SAMF/samfaerosols.F similarity index 100% rename from physics/samfaerosols.F rename to physics/CONV/SAMF/samfaerosols.F diff --git a/physics/samfdeepcnv.f b/physics/CONV/SAMF/samfdeepcnv.f similarity index 99% rename from physics/samfdeepcnv.f rename to physics/CONV/SAMF/samfdeepcnv.f index 8a36fe34c..5853254c0 100644 --- a/physics/samfdeepcnv.f +++ b/physics/CONV/SAMF/samfdeepcnv.f @@ -83,7 +83,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & 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) + & rainevap,sigmain,sigmaout,betadcu,betamcu,betascu, & + & maxMF, do_mynnedmf,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -99,15 +100,16 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) real(kind=kind_phys), dimension(:), intent(in) :: fscav logical, intent(in) :: first_time_step,restart,hwrf_samfdeep, & - & progsigma - real(kind=kind_phys), intent(in) :: nthresh + & progsigma,do_mynnedmf + real(kind=kind_phys), intent(in) :: nthresh,betadcu,betamcu, & + & betascu real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:,:),q(:,:), prevsq(:,:) + real(kind=kind_phys), dimension (:), intent(in) :: maxMF 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(:) ! DH* TODO - check dimensions of qtr, ntr+2 correct? *DH real(kind=kind_phys), intent(inout) :: qtr(:,:,:), & @@ -213,8 +215,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! parameters for prognostic sigma closure real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) - real(kind=kind_phys) gravinv,invdelt - logical flag_shallow + real(kind=kind_phys) gravinv,invdelt,sigmind,sigminm,sigmins + parameter(sigmind=0.01,sigmins=0.03,sigminm=0.01) + logical flag_shallow, flag_mid c physical parameters ! parameter(grav=grav,asolfac=0.958) ! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) @@ -347,6 +350,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! do i=1,im cnvflg(i) = .true. + if(do_mynnedmf) then + if(maxMF(i).gt.0.)cnvflg(i)=.false. + endif sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. mbdt(i)=10. @@ -2930,10 +2936,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo flag_shallow = .false. + flag_mid = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qadv,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab) + & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, + & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, + & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !> - 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. diff --git a/physics/samfdeepcnv.meta b/physics/CONV/SAMF/samfdeepcnv.meta similarity index 94% rename from physics/samfdeepcnv.meta rename to physics/CONV/SAMF/samfdeepcnv.meta index bed4d655d..2dbd4407c 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/CONV/SAMF/samfdeepcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfdeepcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,samfaerosols.F,../progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -450,6 +450,44 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in +[maxMF] + standard_name = maximum_mass_flux + long_name = maximum mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in [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/CONV/SAMF/samfshalcnv.f similarity index 99% rename from physics/samfshalcnv.f rename to physics/CONV/SAMF/samfshalcnv.f index a7682342f..d0bab05dd 100644 --- a/physics/samfshalcnv.f +++ b/physics/CONV/SAMF/samfshalcnv.f @@ -57,7 +57,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & 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) + & sigmain,sigmaout,betadcu,betamcu,betascu,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -67,7 +67,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & integer, intent(in) :: im, km, itc, ntc, ntk, ntr, ncloud integer, intent(in) :: islimsk(:) real(kind=kind_phys), intent(in) :: cliq, cp, cvap, & - & eps, epsm1, fv, grav, hvap, rd, rv, t0c + & eps, epsm1, fv, grav, hvap, rd, rv, t0c, betascu, betadcu, & + & betamcu real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & @@ -159,8 +160,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), & sigmab(im),qadv(im,km) - real(kind=kind_phys) gravinv,dxcrtas,invdelt - logical flag_shallow + real(kind=kind_phys) gravinv,dxcrtas,invdelt,sigmind,sigmins, + & sigminm + logical flag_shallow,flag_mid c physical parameters ! parameter(g=grav,asolfac=0.89) ! parameter(g=grav) @@ -189,12 +191,12 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(cinacrmx=-120.,shevf=2.0) parameter(dtmax=10800.,dtmin=600.) parameter(bb1=4.0,bb2=0.8,csmf=0.2) - parameter(tkcrt=2.,cmxfac=15.) + parameter(tkcrt=2.,cmxfac=10.) ! 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) + parameter(dxcrtas=30.e3,sigmind=0.01,sigmins=0.03,sigminm=0.01) 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), @@ -1974,10 +1976,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo flag_shallow = .true. + flag_mid = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qadv,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab) + & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, + & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, + & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !> - 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. diff --git a/physics/samfshalcnv.meta b/physics/CONV/SAMF/samfshalcnv.meta similarity index 94% rename from physics/samfshalcnv.meta rename to physics/CONV/SAMF/samfshalcnv.meta index c1fffef58..4b913a05d 100644 --- a/physics/samfshalcnv.meta +++ b/physics/CONV/SAMF/samfshalcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = samfshalcnv type = scheme - dependencies = funcphys.f90,machine.F,samfaerosols.F,progsigma_calc.f90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,samfaerosols.F,../progsigma_calc.f90 ######################################################################## [ccpp-arg-table] @@ -482,6 +482,29 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sascnvn.F b/physics/CONV/SAS/sascnvn.F similarity index 100% rename from physics/sascnvn.F rename to physics/CONV/SAS/sascnvn.F diff --git a/physics/sascnvn.meta b/physics/CONV/SAS/sascnvn.meta similarity index 99% rename from physics/sascnvn.meta rename to physics/CONV/SAS/sascnvn.meta index 66e5161ad..fefa2823a 100644 --- a/physics/sascnvn.meta +++ b/physics/CONV/SAS/sascnvn.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sascnvn type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/shalcnv.F b/physics/CONV/SAS/shalcnv.F similarity index 100% rename from physics/shalcnv.F rename to physics/CONV/SAS/shalcnv.F diff --git a/physics/shalcnv.meta b/physics/CONV/SAS/shalcnv.meta similarity index 99% rename from physics/shalcnv.meta rename to physics/CONV/SAS/shalcnv.meta index f554201c5..15324ed08 100644 --- a/physics/shalcnv.meta +++ b/physics/CONV/SAS/shalcnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = shalcnv type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_ntiedtke.F90 b/physics/CONV/nTiedtke/cu_ntiedtke.F90 similarity index 100% rename from physics/cu_ntiedtke.F90 rename to physics/CONV/nTiedtke/cu_ntiedtke.F90 diff --git a/physics/cu_ntiedtke.meta b/physics/CONV/nTiedtke/cu_ntiedtke.meta similarity index 99% rename from physics/cu_ntiedtke.meta rename to physics/CONV/nTiedtke/cu_ntiedtke.meta index dded8fb20..b425a80ad 100644 --- a/physics/cu_ntiedtke.meta +++ b/physics/CONV/nTiedtke/cu_ntiedtke.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_ntiedtke type = scheme - dependencies = machine.F,physcons.F90 + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_ntiedtke_post.F90 b/physics/CONV/nTiedtke/cu_ntiedtke_post.F90 similarity index 100% rename from physics/cu_ntiedtke_post.F90 rename to physics/CONV/nTiedtke/cu_ntiedtke_post.F90 diff --git a/physics/cu_ntiedtke_post.meta b/physics/CONV/nTiedtke/cu_ntiedtke_post.meta similarity index 97% rename from physics/cu_ntiedtke_post.meta rename to physics/CONV/nTiedtke/cu_ntiedtke_post.meta index 703d32b90..9960b6b77 100644 --- a/physics/cu_ntiedtke_post.meta +++ b/physics/CONV/nTiedtke/cu_ntiedtke_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_ntiedtke_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_ntiedtke_pre.F90 b/physics/CONV/nTiedtke/cu_ntiedtke_pre.F90 similarity index 100% rename from physics/cu_ntiedtke_pre.F90 rename to physics/CONV/nTiedtke/cu_ntiedtke_pre.F90 diff --git a/physics/cu_ntiedtke_pre.meta b/physics/CONV/nTiedtke/cu_ntiedtke_pre.meta similarity index 98% rename from physics/cu_ntiedtke_pre.meta rename to physics/CONV/nTiedtke/cu_ntiedtke_pre.meta index ccb9b7f48..26392f0e6 100644 --- a/physics/cu_ntiedtke_pre.meta +++ b/physics/CONV/nTiedtke/cu_ntiedtke_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_ntiedtke_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/progsigma_calc.f90 b/physics/CONV/progsigma_calc.f90 similarity index 88% rename from physics/progsigma_calc.f90 rename to physics/CONV/progsigma_calc.f90 index c87308602..469df49f6 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/CONV/progsigma_calc.f90 @@ -19,10 +19,10 @@ module progsigma !! This subroutine computes a prognostic updraft area fracftion !! used in the closure computations in the samfshalcnv. scheme !!\section gen_progsigma progsigma_calc General Algorithm - subroutine progsigma_calc (im,km,flag_init,flag_restart, & - flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,qadv,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & - sigmab) + subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_shallow,& + flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & + delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) ! ! use machine, only : kind_phys @@ -32,11 +32,12 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) - real(kind=kind_phys), intent(in) :: hvap,delt + real(kind=kind_phys), intent(in) :: hvap,delt,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins real(kind=kind_phys), intent(in) :: qadv(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km) - logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow + logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow,flag_mid real(kind=kind_phys), intent(in) :: sigmain(im,km) ! intent out @@ -53,15 +54,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & fdqb,dtdyn,dxlim,rmulacvg,tem, & - DEN,betascu,betadcu,dp1,invdelt + DEN,dp1,invdelt !Parameters gcvalmx = 0.1 rmulacvg=10. epsilon=1.E-11 km1=km-1 - betadcu = 2.0 - betascu = 8.0 invdelt = 1./delt !Initialization 2D @@ -206,17 +205,27 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do i= 1, im if(cnvflg(i)) then sigmab(i)=sigmab(i)/betascu - sigmab(i)=MAX(0.03,sigmab(i)) + sigmab(i)=MAX(sigmins,sigmab(i)) + endif + enddo + elseif(flag_mid)then + do i= 1, im + if(cnvflg(i)) then + sigmab(i)=sigmab(i)/betamcu + sigmab(i)=MAX(sigminm,sigmab(i)) endif enddo else do i= 1, im if(cnvflg(i)) then sigmab(i)=sigmab(i)/betadcu - sigmab(i)=MAX(0.01,sigmab(i)) + sigmab(i)=MAX(sigmind,sigmab(i)) endif enddo endif + do i= 1, im + sigmab(i) = MIN(0.95,sigmab(i)) + enddo end subroutine progsigma_calc diff --git a/physics/cires_orowam2017.f b/physics/GWD/cires_orowam2017.f similarity index 100% rename from physics/cires_orowam2017.f rename to physics/GWD/cires_orowam2017.f diff --git a/physics/cires_tauamf_data.F90 b/physics/GWD/cires_tauamf_data.F90 similarity index 100% rename from physics/cires_tauamf_data.F90 rename to physics/GWD/cires_tauamf_data.F90 diff --git a/physics/cires_ugwp.F90 b/physics/GWD/cires_ugwp.F90 similarity index 100% rename from physics/cires_ugwp.F90 rename to physics/GWD/cires_ugwp.F90 diff --git a/physics/cires_ugwp.meta b/physics/GWD/cires_ugwp.meta similarity index 99% rename from physics/cires_ugwp.meta rename to physics/GWD/cires_ugwp.meta index d944a635e..cd0192ca7 100644 --- a/physics/cires_ugwp.meta +++ b/physics/GWD/cires_ugwp.meta @@ -3,7 +3,7 @@ type = scheme # DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp-v0! dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 - dependencies=cires_orowam2017.f,cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F + dependencies=cires_orowam2017.f,cires_ugwp_module.F90,gwdps.f,../hooks/machine.F,ugwp_driver_v0.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cires_ugwp_initialize.F90 b/physics/GWD/cires_ugwp_initialize.F90 similarity index 100% rename from physics/cires_ugwp_initialize.F90 rename to physics/GWD/cires_ugwp_initialize.F90 diff --git a/physics/cires_ugwp_module.F90 b/physics/GWD/cires_ugwp_module.F90 similarity index 100% rename from physics/cires_ugwp_module.F90 rename to physics/GWD/cires_ugwp_module.F90 diff --git a/physics/cires_ugwp_post.F90 b/physics/GWD/cires_ugwp_post.F90 similarity index 100% rename from physics/cires_ugwp_post.F90 rename to physics/GWD/cires_ugwp_post.F90 diff --git a/physics/cires_ugwp_post.meta b/physics/GWD/cires_ugwp_post.meta similarity index 99% rename from physics/cires_ugwp_post.meta rename to physics/GWD/cires_ugwp_post.meta index 5add9d43f..dabc40082 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/GWD/cires_ugwp_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cires_ugwp_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cires_ugwp_triggers.F90 b/physics/GWD/cires_ugwp_triggers.F90 similarity index 100% rename from physics/cires_ugwp_triggers.F90 rename to physics/GWD/cires_ugwp_triggers.F90 diff --git a/physics/cires_ugwpv1_initialize.F90 b/physics/GWD/cires_ugwpv1_initialize.F90 similarity index 100% rename from physics/cires_ugwpv1_initialize.F90 rename to physics/GWD/cires_ugwpv1_initialize.F90 diff --git a/physics/cires_ugwpv1_module.F90 b/physics/GWD/cires_ugwpv1_module.F90 similarity index 100% rename from physics/cires_ugwpv1_module.F90 rename to physics/GWD/cires_ugwpv1_module.F90 diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/GWD/cires_ugwpv1_oro.F90 similarity index 100% rename from physics/cires_ugwpv1_oro.F90 rename to physics/GWD/cires_ugwpv1_oro.F90 diff --git a/physics/cires_ugwpv1_solv2.F90 b/physics/GWD/cires_ugwpv1_solv2.F90 similarity index 100% rename from physics/cires_ugwpv1_solv2.F90 rename to physics/GWD/cires_ugwpv1_solv2.F90 diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/GWD/cires_ugwpv1_sporo.F90 similarity index 100% rename from physics/cires_ugwpv1_sporo.F90 rename to physics/GWD/cires_ugwpv1_sporo.F90 diff --git a/physics/cires_ugwpv1_triggers.F90 b/physics/GWD/cires_ugwpv1_triggers.F90 similarity index 100% rename from physics/cires_ugwpv1_triggers.F90 rename to physics/GWD/cires_ugwpv1_triggers.F90 diff --git a/physics/drag_suite.F90 b/physics/GWD/drag_suite.F90 similarity index 100% rename from physics/drag_suite.F90 rename to physics/GWD/drag_suite.F90 diff --git a/physics/drag_suite.meta b/physics/GWD/drag_suite.meta similarity index 99% rename from physics/drag_suite.meta rename to physics/GWD/drag_suite.meta index 66f320b98..94dddcc93 100644 --- a/physics/drag_suite.meta +++ b/physics/GWD/drag_suite.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = drag_suite type = scheme - dependencies = + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdc.f b/physics/GWD/gwdc.f similarity index 100% rename from physics/gwdc.f rename to physics/GWD/gwdc.f diff --git a/physics/gwdc.meta b/physics/GWD/gwdc.meta similarity index 99% rename from physics/gwdc.meta rename to physics/GWD/gwdc.meta index 341879b0b..9884d8a62 100644 --- a/physics/gwdc.meta +++ b/physics/GWD/gwdc.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = gwdc type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdc_post.f b/physics/GWD/gwdc_post.f similarity index 100% rename from physics/gwdc_post.f rename to physics/GWD/gwdc_post.f diff --git a/physics/gwdc_post.meta b/physics/GWD/gwdc_post.meta similarity index 99% rename from physics/gwdc_post.meta rename to physics/GWD/gwdc_post.meta index 25415b888..97649d4cf 100644 --- a/physics/gwdc_post.meta +++ b/physics/GWD/gwdc_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = gwdc_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdc_pre.f b/physics/GWD/gwdc_pre.f similarity index 100% rename from physics/gwdc_pre.f rename to physics/GWD/gwdc_pre.f diff --git a/physics/gwdc_pre.meta b/physics/GWD/gwdc_pre.meta similarity index 99% rename from physics/gwdc_pre.meta rename to physics/GWD/gwdc_pre.meta index 63df59cfa..55b0054bd 100644 --- a/physics/gwdc_pre.meta +++ b/physics/GWD/gwdc_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = gwdc_pre type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gwdps.f b/physics/GWD/gwdps.f similarity index 100% rename from physics/gwdps.f rename to physics/GWD/gwdps.f diff --git a/physics/gwdps.meta b/physics/GWD/gwdps.meta similarity index 99% rename from physics/gwdps.meta rename to physics/GWD/gwdps.meta index af60886ab..bbe7569d0 100644 --- a/physics/gwdps.meta +++ b/physics/GWD/gwdps.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = gwdps type = scheme - dependencies = + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/rayleigh_damp.f b/physics/GWD/rayleigh_damp.f similarity index 100% rename from physics/rayleigh_damp.f rename to physics/GWD/rayleigh_damp.f diff --git a/physics/rayleigh_damp.meta b/physics/GWD/rayleigh_damp.meta similarity index 99% rename from physics/rayleigh_damp.meta rename to physics/GWD/rayleigh_damp.meta index 63025bcff..525acbe8b 100644 --- a/physics/rayleigh_damp.meta +++ b/physics/GWD/rayleigh_damp.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rayleigh_damp type = scheme - dependencies = + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/ugwp_driver_v0.F b/physics/GWD/ugwp_driver_v0.F similarity index 100% rename from physics/ugwp_driver_v0.F rename to physics/GWD/ugwp_driver_v0.F diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/GWD/ugwpv1_gsldrag.F90 similarity index 100% rename from physics/ugwpv1_gsldrag.F90 rename to physics/GWD/ugwpv1_gsldrag.F90 diff --git a/physics/ugwpv1_gsldrag.meta b/physics/GWD/ugwpv1_gsldrag.meta similarity index 99% rename from physics/ugwpv1_gsldrag.meta rename to physics/GWD/ugwpv1_gsldrag.meta index 82caa8832..73d7eee1c 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/GWD/ugwpv1_gsldrag.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = ugwpv1_gsldrag type = scheme - dependencies = machine.F,drag_suite.F90 + dependencies = ../hooks/machine.F,drag_suite.F90 dependencies = cires_ugwpv1_module.F90,cires_ugwpv1_triggers.F90,cires_ugwpv1_initialize.F90,cires_ugwpv1_solv2.F90 dependencies = cires_ugwpv1_sporo.F90,cires_ugwpv1_oro.F90 ######################################################################## diff --git a/physics/ugwpv1_gsldrag_post.F90 b/physics/GWD/ugwpv1_gsldrag_post.F90 similarity index 100% rename from physics/ugwpv1_gsldrag_post.F90 rename to physics/GWD/ugwpv1_gsldrag_post.F90 diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/GWD/ugwpv1_gsldrag_post.meta similarity index 99% rename from physics/ugwpv1_gsldrag_post.meta rename to physics/GWD/ugwpv1_gsldrag_post.meta index f8766060c..e1c63102d 100644 --- a/physics/ugwpv1_gsldrag_post.meta +++ b/physics/GWD/ugwpv1_gsldrag_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = ugwpv1_gsldrag_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/unified_ugwp.F90 b/physics/GWD/unified_ugwp.F90 similarity index 100% rename from physics/unified_ugwp.F90 rename to physics/GWD/unified_ugwp.F90 diff --git a/physics/unified_ugwp.meta b/physics/GWD/unified_ugwp.meta similarity index 99% rename from physics/unified_ugwp.meta rename to physics/GWD/unified_ugwp.meta index 8af99957a..a08ee3960 100644 --- a/physics/unified_ugwp.meta +++ b/physics/GWD/unified_ugwp.meta @@ -1,10 +1,10 @@ [ccpp-table-properties] name = unified_ugwp type = scheme - - dependencies=cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 - dependencies=cires_orowam2017.f, cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F - dependencies=drag_suite.F90 + dependencies = ../hooks/machine.F + dependencies = cires_ugwp_triggers.F90,cires_ugwp_initialize.F90 + dependencies = cires_orowam2017.f,cires_ugwp_module.F90,gwdps.f,ugwp_driver_v0.F + dependencies = drag_suite.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/unified_ugwp_post.F90 b/physics/GWD/unified_ugwp_post.F90 similarity index 100% rename from physics/unified_ugwp_post.F90 rename to physics/GWD/unified_ugwp_post.F90 diff --git a/physics/unified_ugwp_post.meta b/physics/GWD/unified_ugwp_post.meta similarity index 99% rename from physics/unified_ugwp_post.meta rename to physics/GWD/unified_ugwp_post.meta index 6da6342df..7784c28ec 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/GWD/unified_ugwp_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = unified_ugwp_post type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_DCNV_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.F90 similarity index 100% rename from physics/GFS_DCNV_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.F90 diff --git a/physics/GFS_DCNV_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.meta similarity index 99% rename from physics/GFS_DCNV_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.meta index 191e83a3a..ab8982e11 100644 --- a/physics/GFS_DCNV_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_DCNV_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_DCNV_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.F90 similarity index 100% rename from physics/GFS_DCNV_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.F90 diff --git a/physics/GFS_DCNV_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.meta similarity index 99% rename from physics/GFS_DCNV_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.meta index a9008436e..ec1c59810 100644 --- a/physics/GFS_DCNV_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_DCNV_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_DCNV_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_GWD_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.F90 similarity index 100% rename from physics/GFS_GWD_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.F90 diff --git a/physics/GFS_GWD_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.meta similarity index 99% rename from physics/GFS_GWD_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.meta index 204c16c84..beca39282 100644 --- a/physics/GFS_GWD_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_GWD_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_GWD_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.F90 similarity index 100% rename from physics/GFS_GWD_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.F90 diff --git a/physics/GFS_GWD_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.meta similarity index 99% rename from physics/GFS_GWD_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.meta index 9bcc03300..dbbfc261d 100644 --- a/physics/GFS_GWD_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_GWD_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_GWD_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_MP_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 similarity index 90% rename from physics/GFS_MP_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 index 201c0e817..d9d30fb90 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 @@ -21,7 +21,8 @@ module GFS_MP_generic_post subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rhowater, rainmin, dtf, & - frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, & + frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, phil, htop, refl_10cm, & + imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf, con_t0c, snow, graupel, save_t, save_q, & rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp,& totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, & pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, & @@ -40,12 +41,13 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: imp_physics_nssl, iopt_lake_clm, iopt_lake, lkm logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma, exticeden integer, intent(in) :: index_of_temperature,index_of_process_mp,use_lake_model(:) - + integer, intent(in) :: imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf + integer, dimension (:), intent(in) :: htop integer :: dfi_radar_max_intervals - real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour + real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour, con_t0c real(kind=kind_phys), intent(in) :: radar_tten_limits(:) integer :: ix_dfi_radar(:) - real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0 + real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0,refl_10cm real(kind=kind_phys), intent(in) :: dtf, frain, con_g, rainmin, rhowater real(kind=kind_phys), dimension(:), intent(in) :: rain1, xlat, xlon, tsfc @@ -53,7 +55,7 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(in) :: rain0, ice0, snow0, graupel0 real(kind=kind_phys), dimension(:,:), intent(in) :: rann real(kind=kind_phys), dimension(:,:), intent(in) :: prsl, save_t, del - real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii + real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii,phil real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0, save_q real(kind=kind_phys), dimension(:,:,:), intent(in) :: dfi_radar_tten @@ -112,6 +114,17 @@ subroutine GFS_MP_generic_post_run( real :: snowrat,grauprat,icerat,curat,prcpncfr,prcpcufr real :: rhonewsnow,rhoprcpice,rhonewgr,rhonewice + real(kind_phys), parameter :: dbzmin=-20.0 + real(kind_phys) :: cuprate + real(kind_phys) :: ze, ze_conv, dbz_sum + + real(kind_phys), dimension(1:im,1:levs) :: zo + real(kind_phys), dimension(1:im) :: zfrz + real(kind_phys), dimension(1:im) :: factor + real(kind_phys) ze_mp, fctz, delz + logical :: lfrz + + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -121,6 +134,52 @@ subroutine GFS_MP_generic_post_run( do i = 1, im rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit enddo +! +! Combine convective reflectivity with MP reflectivity for selected +! parameterizations. + if ( (imp_physics==imp_physics_thompson .or. imp_physics==imp_physics_nssl) .and. & + (imfdeepcnv==imfdeepcnv_samf .or. imfdeepcnv==imfdeepcnv_gf .or. imfshalcnv==imfshalcnv_gf) ) then + do i=1,im + factor(i) = 0.0 + lfrz = .true. + zfrz(i) = phil(i,1)*onebg + do k = levs, 1, -1 + zo(i,k) = phil(i,k)*onebg + if (gt0(i,k) >= con_t0c .and. lfrz) then + zfrz(i) = zo(i,k) + lfrz = .false. + endif + enddo + enddo +! + do i=1,im + if(rainc (i) > 0.0 .and. htop(i) > 0) then + factor(i) = -2./max(1000., zo(i,htop(i)) - zfrz(i)) + endif + enddo + +! combine the reflectivity from both Thompson MP and samfdeep convection + + do k=1,levs + do i=1,im + if(rainc(i) > 0. .and. k <= htop(i)) then + fctz = 0.0 + delz = zo(i,k) - zfrz(i) + if(delz <0.0) then + fctz = 1. ! wrong + else + fctz = 10.**(factor(i)*delz) + endif + cuprate = rainc(i) * 3.6e6 / dtp ! cu precip rate (mm/h) + ze_conv = 300.0 * cuprate**1.4 + ze_conv = fctz * ze_conv + ze_mp = 10._kind_phys ** (0.1 * refl_10cm(i,k)) + dbz_sum = max(DBZmin, 10.*log10(ze_mp + ze_conv)) + refl_10cm(i,k) = dbz_sum + endif + enddo + enddo + endif ! compute surface snowfall, graupel/sleet, freezing rain and precip ice density if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then diff --git a/physics/GFS_MP_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta similarity index 93% rename from physics/GFS_MP_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta index 7cd2ca4b5..7f67aa925 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_MP_generic_post type = scheme - dependencies = calpreciptype.f90,machine.F + dependencies = ../../MP/calpreciptype.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -254,6 +254,72 @@ type = real kind = kind_phys intent = in +[phil] + standard_name = geopotential + long_name = layer geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[htop] + standard_name = vertical_index_at_cloud_top + long_name = index for cloud top + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[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_gf] + standard_name = identifier_for_grell_freitas_shallow_convection + long_name = flag for Grell-Freitas shallow convection scheme + units = flag + dimensions = () + type = integer + 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_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas 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 +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [tsfc] standard_name = surface_skin_temperature long_name = surface skin temperature diff --git a/physics/GFS_MP_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.F90 similarity index 100% rename from physics/GFS_MP_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.F90 diff --git a/physics/GFS_MP_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.meta similarity index 98% rename from physics/GFS_MP_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.meta index a2a4947ef..6d5fd1538 100644 --- a/physics/GFS_MP_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_MP_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_PBL_generic_common.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_common.F90 similarity index 100% rename from physics/GFS_PBL_generic_common.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_common.F90 diff --git a/physics/GFS_PBL_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.F90 similarity index 100% rename from physics/GFS_PBL_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.F90 diff --git a/physics/GFS_PBL_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.meta similarity index 99% rename from physics/GFS_PBL_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.meta index a53acbc64..d49a885c5 100644 --- a/physics/GFS_PBL_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_PBL_generic_post type = scheme - dependencies = GFS_PBL_generic_common.F90,machine.F + dependencies = GFS_PBL_generic_common.F90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_PBL_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.F90 similarity index 100% rename from physics/GFS_PBL_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.F90 diff --git a/physics/GFS_PBL_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.meta similarity index 99% rename from physics/GFS_PBL_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.meta index 995fac565..7a8e72bba 100644 --- a/physics/GFS_PBL_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_PBL_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_PBL_generic_pre type = scheme - dependencies = GFS_PBL_generic_common.F90,machine.F + dependencies = GFS_PBL_generic_common.F90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_SCNV_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.F90 similarity index 100% rename from physics/GFS_SCNV_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.F90 diff --git a/physics/GFS_SCNV_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.meta similarity index 99% rename from physics/GFS_SCNV_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.meta index bf6ba394f..963ad4a81 100644 --- a/physics/GFS_SCNV_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_SCNV_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_SCNV_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.F90 similarity index 100% rename from physics/GFS_SCNV_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.F90 diff --git a/physics/GFS_SCNV_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.meta similarity index 99% rename from physics/GFS_SCNV_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.meta index eccd547a1..fbd9e47d8 100644 --- a/physics/GFS_SCNV_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_SCNV_generic_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_SCNV_generic_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.F90 similarity index 100% rename from physics/GFS_cloud_diagnostics.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.F90 diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.meta similarity index 98% rename from physics/GFS_cloud_diagnostics.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.meta index 53d1552e6..576c66463 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_cloud_diagnostics type = scheme - dependencies = machine.F,radiation_clouds.f + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/radiation_clouds.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_debug.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.F90 similarity index 99% rename from physics/GFS_debug.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.F90 index fe63c1cea..ed26b795f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.F90 @@ -747,9 +747,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_thl ', Diag%det_thl) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_sqv ', Diag%det_sqv) end if - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%nupdraft ', Diag%nupdraft) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%maxwidth ', Diag%maxwidth) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%maxMF ', Diag%maxMF) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ktop_plume ', Diag%ktop_plume) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ztop_plume ', Diag%ztop_plume) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_h ', Diag%exch_h) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if diff --git a/physics/GFS_debug.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.meta similarity index 99% rename from physics/GFS_debug.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.meta index 1ad24e1d6..10eb43671 100644 --- a/physics/GFS_debug.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_debug.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_diagtoscreen type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -200,7 +200,7 @@ [ccpp-table-properties] name = GFS_interstitialtoscreen type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -399,7 +399,7 @@ [ccpp-table-properties] name = GFS_abort type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -439,7 +439,7 @@ [ccpp-table-properties] name = GFS_checkland type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -698,7 +698,7 @@ [ccpp-table-properties] name = GFS_checktracers type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 similarity index 96% rename from physics/GFS_phys_time_vary.fv3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 index 4b6909f74..f53ab3928 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 @@ -222,24 +222,6 @@ subroutine GFS_phys_time_vary_init ( jamin=999 jamax=-999 -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP shared (me,master,ntoz,h2o_phys,im,nx,ny,levs,idate) & -!$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) & -!$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) & -!$OMP shared (iamin, iamax, jamin, jamax, lsm_noahmp) & -!$OMP shared (iaerclm,iaermdl,ntrcaer,aer_nm,iflip,iccn) & -!$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & -!$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & -!$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & -!$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & -!$OMP shared (isot,ivegsrc,nlunit,sncovr,sncovr_ice,lsm,lsm_ruc) & -!$OMP shared (min_seaice,fice,landfrac,vtype,weasd,snupx,salp_data) & -!$OMP shared (ozphys) & -!$OMP private (ix,i,j,rsnow,vegtyp,myerrmsg,myerrflg) - -!$OMP sections - -!$OMP section !> - Call read_h2odata() to read stratospheric water vapor data need_h2odata: if(h2o_phys) then call read_h2odata (h2o_phys, me, master) @@ -263,7 +245,6 @@ subroutine GFS_phys_time_vary_init ( end if endif need_h2odata -!$OMP section !> - Call read_aerdata() to read aerosol climatology, Anning added coupled !> added coupled gocart and radiation option to initializing aer_nm if (iaerclm) then @@ -285,7 +266,6 @@ subroutine GFS_phys_time_vary_init ( ntrcaer = 1 endif -!$OMP section !> - Call read_cidata() to read IN and CCN data if (iccn == 1) then call read_cidata (me,master) @@ -293,7 +273,6 @@ subroutine GFS_phys_time_vary_init ( ! hardcoded in module iccn_def.F and GFS_typedefs.F90 endif -!$OMP section !> - Call tau_amf dats for ugwp_v1 if (do_ugwp_v1) then myerrflg = 0 @@ -302,14 +281,12 @@ subroutine GFS_phys_time_vary_init ( call copy_error(myerrmsg, myerrflg, errmsg, errflg) endif -!$OMP section !> - Initialize soil vegetation (needed for sncovr calculation further down) myerrflg = 0 myerrmsg = 'set_soilveg failed without a message' call set_soilveg(me, isot, ivegsrc, nlunit, myerrmsg, myerrflg) call copy_error(myerrmsg, myerrflg, errmsg, errflg) -!$OMP section !> - read in NoahMP table (needed for NoahMP init) if(lsm == lsm_noahmp) then myerrflg = 0 @@ -318,25 +295,19 @@ subroutine GFS_phys_time_vary_init ( call copy_error(myerrmsg, myerrflg, errmsg, errflg) endif -!$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") -!$OMP sections - -!$OMP section !> - Setup spatial interpolation indices for ozone physics. if (ntoz > 0) then call ozphys%setup_o3prog(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) endif -!$OMP section !> - Call setindxh2o() to initialize stratospheric water vapor data if (h2o_phys) then call setindxh2o (im, xlat_d, jindx1_h, jindx2_h, ddy_h) endif -!$OMP section !> - Call setindxaer() to initialize aerosols data if (iaerclm) then call setindxaer (im, xlat_d, jindx1_aer, & @@ -349,7 +320,6 @@ subroutine GFS_phys_time_vary_init ( jamax = max(maxval(jindx2_aer), jamax) endif -!$OMP section !> - Call setindxci() to initialize IN and CCN data if (iccn == 1) then call setindxci (im, xlat_d, jindx1_ci, & @@ -357,14 +327,12 @@ subroutine GFS_phys_time_vary_init ( iindx1_ci, iindx2_ci, ddx_ci) endif -!$OMP section !> - Call cires_indx_ugwp to read monthly-mean GW-tau diagnosed from FV3GFS-runs that can resolve GWs if (do_ugwp_v1) then call cires_indx_ugwp (im, me, master, xlat_d, jindx1_tau, jindx2_tau, & ddy_j1tau, ddy_j2tau) endif -!$OMP section !--- initial calculation of maps local ix -> global i and j ix = 0 do j = 1,ny @@ -375,7 +343,6 @@ subroutine GFS_phys_time_vary_init ( enddo enddo -!$OMP section !--- if sncovr does not exist in the restart, need to create it if (all(sncovr < zero)) then if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' @@ -404,10 +371,6 @@ subroutine GFS_phys_time_vary_init ( endif endif -!$OMP end sections - -!$OMP end parallel - if (errflg/=0) return if (iaerclm) then diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta similarity index 98% rename from physics/GFS_phys_time_vary.fv3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta index 968f33027..a1990ed43 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta @@ -1,8 +1,16 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90,module_ozphys.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Interstitials/UFS_SCM_NEPTUNE/gcycle.F90,Interstitials/UFS_SCM_NEPTUNE/iccn_def.F + dependencies = Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90,Interstitials/UFS_SCM_NEPTUNE/sfcsub.F + dependencies = Radiation/mersenne_twister.f + dependencies = MP/Morrison_Gettelman/aerclm_def.F,MP/Morrison_Gettelman/aerinterp.F90 + dependencies = SFC_Models/Land/Noah/namelist_soilveg.f,SFC_Models/Land/Noah/set_soilveg.f,SFC_Models/Land/Noahmp/noahmp_tables.f90 + dependencies = photochem/module_ozphys.F90 + dependencies = photochem/h2o_def.f,photochem/h2ointerp.f90 + dependencies = GWD/cires_tauamf_data.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 similarity index 100% rename from physics/GFS_phys_time_vary.scm.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta similarity index 98% rename from physics/GFS_phys_time_vary.scm.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta index d72e27fd5..a9094a075 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta @@ -1,8 +1,15 @@ [ccpp-table-properties] name = GFS_phys_time_vary type = scheme - dependencies = aerclm_def.F,aerinterp.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,module_ozphys.F90,cires_tauamf_data.F90,noahmp_tables.f90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Interstitials/UFS_SCM_NEPTUNE/iccn_def.F,Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90 + dependencies = Interstitials/UFS_SCM_NEPTUNE/sfcsub.F,Radiation/mersenne_twister.f + dependencies = MP/Morrison_Gettelman/aerclm_def.F,MP/Morrison_Gettelman/aerinterp.F90 + dependencies = SFC_Models/Land/Noah/namelist_soilveg.f,SFC_Models/Land/Noah/set_soilveg.f,SFC_Models/Land/Noahmp/noahmp_tables.f90 + dependencies = photochem/module_ozphys.F90 + dependencies = photochem/h2o_def.f,photochem/h2ointerp.f90 + dependencies = GWD/cires_tauamf_data.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_physics_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 similarity index 100% rename from physics/GFS_physics_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 diff --git a/physics/GFS_physics_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta similarity index 99% rename from physics/GFS_physics_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta index 5701909fd..758b9d8b8 100644 --- a/physics/GFS_physics_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_physics_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.F90 similarity index 100% rename from physics/GFS_rad_time_vary.fv3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.F90 diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.meta similarity index 98% rename from physics/GFS_rad_time_vary.fv3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.meta index 19eb41dc2..0759b7e2a 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.fv3.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,radcons.f90 + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/mersenne_twister.f,Radiation/RRTMG/radcons.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rad_time_vary.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.F90 similarity index 100% rename from physics/GFS_rad_time_vary.scm.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.F90 diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.meta similarity index 98% rename from physics/GFS_rad_time_vary.scm.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.meta index 19eb41dc2..0759b7e2a 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.scm.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,radcons.f90 + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/mersenne_twister.f,Radiation/RRTMG/radcons.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_radiation_surface.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.F90 similarity index 100% rename from physics/GFS_radiation_surface.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.F90 diff --git a/physics/GFS_radiation_surface.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.meta similarity index 98% rename from physics/GFS_radiation_surface.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.meta index 9d5734706..686bd3c6c 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.meta @@ -1,7 +1,10 @@ [ccpp-table-properties] name = GFS_radiation_surface type = scheme - dependencies = iounitdef.f,machine.F,radiation_surface.f,set_soilveg_ruc.F90,namelist_soilveg_ruc.F90 + relative_path = ../../ + dependencies = Radiation/radiation_surface.f + dependencies = SFC_Models/Land/RUC/set_soilveg_ruc.F90,SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmg_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.F90 similarity index 100% rename from physics/GFS_rrtmg_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.F90 diff --git a/physics/GFS_rrtmg_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.meta similarity index 97% rename from physics/GFS_rrtmg_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.meta index 5fa6328a7..b387c3e33 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmg_post type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,radsw_param.f + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_aerosols.f,Radiation/RRTMG/radlw_param.f,Radiation/RRTMG/radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 similarity index 100% rename from physics/GFS_rrtmg_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 diff --git a/physics/GFS_rrtmg_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta similarity index 98% rename from physics/GFS_rrtmg_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta index a29b0ac3c..43802298b 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta @@ -1,9 +1,14 @@ [ccpp-table-properties] name = GFS_rrtmg_pre type = scheme - dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90 - dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f,module_ozphys.F90 - dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F + dependencies = MP/Thompson/module_mp_thompson.F90,MP/Thompson/module_mp_thompson_make_number_concentrations.F90 + dependencies = Radiation/RRTMG/radcons.f90,Radiation/radiation_aerosols.f + dependencies = Radiation/radiation_astronomy.f,Radiation/radiation_clouds.f,Radiation/radiation_gases.f + dependencies = Radiation/RRTMG/radlw_param.f,Radiation/RRTMG/radsw_param.f,Radiation/radiation_cloud_overlap.F90 + dependencies = SFC_Models/Land/Noah/surface_perturbation.F90 + dependencies = photochem/module_ozphys.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 similarity index 100% rename from physics/GFS_rrtmg_setup.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 diff --git a/physics/GFS_rrtmg_setup.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta similarity index 97% rename from physics/GFS_rrtmg_setup.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta index 35713757b..7f7ad7532 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.meta @@ -1,8 +1,12 @@ [ccpp-table-properties] name = GFS_rrtmg_setup type = scheme - dependencies = iounitdef.f,module_bfmicrophysics.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f - dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F,module_ozphys.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_aerosols.f + dependencies = Radiation/radiation_astronomy.f,Radiation/radiation_clouds.f,Radiation/radiation_gases.f + dependencies = Radiation/RRTMG/radlw_main.F90,Radiation/RRTMG/radlw_param.f,Radiation/RRTMG/radsw_main.F90,Radiation/RRTMG/radsw_param.f + dependencies = MP/Thompson/module_mp_thompson.F90,photochem/module_ozphys.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.F90 similarity index 100% rename from physics/GFS_rrtmgp_cloud_mp.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.F90 diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.meta similarity index 98% rename from physics/GFS_rrtmgp_cloud_mp.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.meta index b782e73b4..f67259b87 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.meta @@ -1,7 +1,10 @@ [ccpp-table-properties] name = GFS_rrtmgp_cloud_mp type = scheme - dependencies = radiation_tools.F90, radiation_clouds.f, module_mp_thompson_make_number_concentrations.F90, module_mp_thompson.F90, rrtmgp_lw_cloud_optics.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_tools.F90,Radiation/radiation_clouds.f,Radiation/RRTMGP/rrtmgp_lw_cloud_optics.F90 + dependencies = MP/Thompson/module_mp_thompson_make_number_concentrations.F90,MP/Thompson/module_mp_thompson.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.F90 similarity index 100% rename from physics/GFS_rrtmgp_cloud_overlap.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.F90 diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.meta similarity index 98% rename from physics/GFS_rrtmgp_cloud_overlap.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.meta index cf6a05217..4d9af626d 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmgp_cloud_overlap type = scheme - dependencies = radiation_tools.F90, radiation_cloud_overlap.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = Radiation/radiation_tools.F90,Radiation/radiation_cloud_overlap.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.F90 similarity index 100% rename from physics/GFS_rrtmgp_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.F90 diff --git a/physics/GFS_rrtmgp_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.meta similarity index 98% rename from physics/GFS_rrtmgp_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.meta index e4bc3e5dc..5b355849a 100644 --- a/physics/GFS_rrtmgp_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmgp_post type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,radiation_tools.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 + relative_path = ../../ + dependencies = hooks/machine.F,Radiation/radiation_aerosols.f + dependencies = Radiation/RRTMG/radlw_param.f,Radiation/radiation_tools.F90,Radiation/RRTMGP/rte-rrtmgp/extensions/mo_heating_rates.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 similarity index 100% rename from physics/GFS_rrtmgp_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.meta similarity index 98% rename from physics/GFS_rrtmgp_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.meta index 4e2aa3a56..bd767d14b 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.meta @@ -1,8 +1,9 @@ [ccpp-table-properties] name = GFS_rrtmgp_pre type = scheme - dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90,module_ozphys.F90 + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F,Radiation/radiation_aerosols.f,photochem/module_ozphys.F90 + dependencies = Radiation/radiation_astronomy.f,Radiation/radiation_gases.f,Radiation/radiation_tools.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 similarity index 100% rename from physics/GFS_rrtmgp_setup.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.meta similarity index 98% rename from physics/GFS_rrtmgp_setup.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.meta index 96f7e24e7..fecb716ed 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.meta @@ -1,8 +1,10 @@ [ccpp-table-properties] name = GFS_rrtmgp_setup type = scheme - dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,radiation_aerosols.f,radiation_astronomy.f - dependencies = module_mp_thompson.F90,radiation_gases.f,module_ozphys.F90 + relative_path = ../../ + dependencies = hooks/machine.F,MP/Thompson/module_mp_thompson.F90 + dependencies = Radiation/radiation_aerosols.f,photochem/module_ozphys.F90 + dependencies = Radiation/radiation_gases.f,Radiation/radiation_astronomy.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_stochastics.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.F90 similarity index 100% rename from physics/GFS_stochastics.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.F90 diff --git a/physics/GFS_stochastics.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.meta similarity index 99% rename from physics/GFS_stochastics.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.meta index 796f4ddf7..6c55a09de 100644 --- a/physics/GFS_stochastics.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_stochastics.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_stochastics type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F [ccpp-arg-table] name = GFS_stochastics_init diff --git a/physics/GFS_suite_interstitial_1.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.F90 similarity index 100% rename from physics/GFS_suite_interstitial_1.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.F90 diff --git a/physics/GFS_suite_interstitial_1.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.meta similarity index 99% rename from physics/GFS_suite_interstitial_1.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.meta index a465ed320..295ffdf2e 100644 --- a/physics/GFS_suite_interstitial_1.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_1.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_1 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_2.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.F90 similarity index 100% rename from physics/GFS_suite_interstitial_2.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.F90 diff --git a/physics/GFS_suite_interstitial_2.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.meta similarity index 99% rename from physics/GFS_suite_interstitial_2.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.meta index 1f4300574..de4db5f9f 100644 --- a/physics/GFS_suite_interstitial_2.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_2.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_2 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 similarity index 100% rename from physics/GFS_suite_interstitial_3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta similarity index 99% rename from physics/GFS_suite_interstitial_3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta index e8f9fe889..22f57e354 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_3 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 similarity index 100% rename from physics/GFS_suite_interstitial_4.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 diff --git a/physics/GFS_suite_interstitial_4.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta similarity index 98% rename from physics/GFS_suite_interstitial_4.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta index 92870d95f..c0df52f1a 100644 --- a/physics/GFS_suite_interstitial_4.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta @@ -2,7 +2,9 @@ [ccpp-table-properties] name = GFS_suite_interstitial_4 type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + relative_path = ../../ + dependencies = hooks/machine.F + dependencies = MP/Thompson/module_mp_thompson_make_number_concentrations.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_5.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.F90 similarity index 100% rename from physics/GFS_suite_interstitial_5.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.F90 diff --git a/physics/GFS_suite_interstitial_5.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.meta similarity index 98% rename from physics/GFS_suite_interstitial_5.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.meta index 9d32160a1..511137901 100644 --- a/physics/GFS_suite_interstitial_5.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_5.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_5 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_phys_reset.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.F90 similarity index 100% rename from physics/GFS_suite_interstitial_phys_reset.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.F90 diff --git a/physics/GFS_suite_interstitial_phys_reset.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.meta similarity index 96% rename from physics/GFS_suite_interstitial_phys_reset.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.meta index adebbc833..947a1950f 100644 --- a/physics/GFS_suite_interstitial_phys_reset.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_phys_reset.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_phys_reset type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_interstitial_rad_reset.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.F90 similarity index 100% rename from physics/GFS_suite_interstitial_rad_reset.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.F90 diff --git a/physics/GFS_suite_interstitial_rad_reset.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.meta similarity index 96% rename from physics/GFS_suite_interstitial_rad_reset.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.meta index 91fd8cba7..aaaff02f5 100644 --- a/physics/GFS_suite_interstitial_rad_reset.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_rad_reset.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_suite_interstitial_rad_reset type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_stateout_reset.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.F90 similarity index 100% rename from physics/GFS_suite_stateout_reset.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.F90 diff --git a/physics/GFS_suite_stateout_reset.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.meta similarity index 98% rename from physics/GFS_suite_stateout_reset.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.meta index fa4111e6b..b84d10691 100644 --- a/physics/GFS_suite_stateout_reset.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_reset.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_stateout_reset type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_suite_stateout_update.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.F90 similarity index 100% rename from physics/GFS_suite_stateout_update.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.F90 diff --git a/physics/GFS_suite_stateout_update.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.meta similarity index 99% rename from physics/GFS_suite_stateout_update.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.meta index fae276d2f..9f8977482 100644 --- a/physics/GFS_suite_stateout_update.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_stateout_update.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_stateout_update type = scheme - dependencies = machine.F,module_ozphys.F90 + dependencies = ../../hooks/machine.F,../../photochem/module_ozphys.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_composites_inter.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.F90 similarity index 100% rename from physics/GFS_surface_composites_inter.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.F90 diff --git a/physics/GFS_surface_composites_inter.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.meta similarity index 99% rename from physics/GFS_surface_composites_inter.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.meta index 36af0ef5a..ef3005583 100644 --- a/physics/GFS_surface_composites_inter.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_inter.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_surface_composites_inter type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_composites_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.F90 similarity index 100% rename from physics/GFS_surface_composites_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.F90 diff --git a/physics/GFS_surface_composites_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.meta similarity index 99% rename from physics/GFS_surface_composites_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.meta index a78610cc7..7224d7221 100644 --- a/physics/GFS_surface_composites_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.meta @@ -2,7 +2,8 @@ [ccpp-table-properties] name = GFS_surface_composites_post type = scheme - dependencies = machine.F,sfc_diff.f + relative_path = ../../ + dependencies = hooks/machine.F,SFC_Layer/UFS/sfc_diff.f ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90 similarity index 98% rename from physics/GFS_surface_composites_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90 index 98b9fecd2..fd16dea59 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90 @@ -241,8 +241,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, iopt_lake, iopt_l !mjz tsfcl(i) = huge endif + if (icy(i) .or. wet(i)) then ! init uustar_ice for all water/ice grids + uustar_ice(i) = uustar(i) + endif if (icy(i)) then ! Ice - uustar_ice(i) = uustar(i) is_clm = lkm>0 .and. iopt_lake==iopt_lake_clm .and. use_lake_model(i)>0 if(lsm /= lsm_ruc .and. .not.is_clm) then weasd_ice(i) = weasd(i) diff --git a/physics/GFS_surface_composites_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.meta similarity index 99% rename from physics/GFS_surface_composites_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.meta index d6b9003fe..33e2f0523 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_surface_composites_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.F90 similarity index 100% rename from physics/GFS_surface_generic_post.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.F90 diff --git a/physics/GFS_surface_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.meta similarity index 99% rename from physics/GFS_surface_generic_post.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.meta index 9658be7d8..2c28b17d7 100644 --- a/physics/GFS_surface_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_surface_generic_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_generic_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.F90 similarity index 100% rename from physics/GFS_surface_generic_pre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.F90 diff --git a/physics/GFS_surface_generic_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.meta similarity index 99% rename from physics/GFS_surface_generic_pre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.meta index d78988787..bbf7dd5c3 100644 --- a/physics/GFS_surface_generic_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_generic_pre.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_surface_generic_pre type = scheme - dependencies = machine.F,surface_perturbation.F90 + relative_path = ../../ + dependencies = hooks/machine.F,SFC_Models/Land/Noah/surface_perturbation.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_loop_control_part1.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.F90 similarity index 100% rename from physics/GFS_surface_loop_control_part1.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.F90 diff --git a/physics/GFS_surface_loop_control_part1.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.meta similarity index 97% rename from physics/GFS_surface_loop_control_part1.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.meta index f178320ee..4bf962f6e 100644 --- a/physics/GFS_surface_loop_control_part1.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_surface_loop_control_part1 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_surface_loop_control_part2.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.F90 similarity index 100% rename from physics/GFS_surface_loop_control_part2.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.F90 diff --git a/physics/GFS_surface_loop_control_part2.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.meta similarity index 98% rename from physics/GFS_surface_loop_control_part2.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.meta index 7c9bc7408..ba19bf437 100644 --- a/physics/GFS_surface_loop_control_part2.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_surface_loop_control_part2 type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 similarity index 100% rename from physics/GFS_time_vary_pre.fv3.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90 diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta similarity index 98% rename from physics/GFS_time_vary_pre.fv3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta index 3ec92287a..c6dd95bce 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_time_vary_pre type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 similarity index 100% rename from physics/GFS_time_vary_pre.scm.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.F90 diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta similarity index 98% rename from physics/GFS_time_vary_pre.scm.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta index 20708c51e..af9afcdfe 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.scm.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = GFS_time_vary_pre type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cnvc90.f b/physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.f similarity index 100% rename from physics/cnvc90.f rename to physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.f diff --git a/physics/cnvc90.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.meta similarity index 98% rename from physics/cnvc90.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.meta index 9728266d4..bbf161eb5 100644 --- a/physics/cnvc90.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/cnvc90.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cnvc90 type = scheme - dependencies = + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/dcyc2t3.f b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f similarity index 100% rename from physics/dcyc2t3.f rename to physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f diff --git a/physics/dcyc2t3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta similarity index 99% rename from physics/dcyc2t3.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta index 65b05f4b3..95b3f341b 100644 --- a/physics/dcyc2t3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = dcyc2t3 type = scheme - dependencies = machine.F,physcons.F90 + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gcycle.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/gcycle.F90 similarity index 100% rename from physics/gcycle.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/gcycle.F90 diff --git a/physics/iccn_def.F b/physics/Interstitials/UFS_SCM_NEPTUNE/iccn_def.F similarity index 100% rename from physics/iccn_def.F rename to physics/Interstitials/UFS_SCM_NEPTUNE/iccn_def.F diff --git a/physics/iccninterp.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90 similarity index 100% rename from physics/iccninterp.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/iccninterp.F90 diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.F90 similarity index 100% rename from physics/maximum_hourly_diagnostics.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.F90 diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.meta similarity index 99% rename from physics/maximum_hourly_diagnostics.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.meta index e9d0876d2..0c2d1bcbe 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/maximum_hourly_diagnostics.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = maximum_hourly_diagnostics type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.F90 similarity index 100% rename from physics/scm_sfc_flux_spec.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.F90 diff --git a/physics/scm_sfc_flux_spec.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.meta similarity index 99% rename from physics/scm_sfc_flux_spec.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.meta index 52722f1c4..85bf403ad 100644 --- a/physics/scm_sfc_flux_spec.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/scm_sfc_flux_spec.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = scm_sfc_flux_spec type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sfcsub.F b/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F similarity index 100% rename from physics/sfcsub.F rename to physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F diff --git a/physics/sgscloud_radpost.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.F90 similarity index 100% rename from physics/sgscloud_radpost.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.F90 diff --git a/physics/sgscloud_radpost.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.meta similarity index 98% rename from physics/sgscloud_radpost.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.meta index 6ad91d496..046531a0a 100644 --- a/physics/sgscloud_radpost.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpost.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sgscloud_radpost type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sgscloud_radpre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.F90 similarity index 98% rename from physics/sgscloud_radpre.F90 rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.F90 index 44ab87bcc..936393d5b 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.F90 @@ -216,10 +216,10 @@ subroutine sgscloud_radpre_run( & 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.) + clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 8b) !iwc = qi(i,k)*1.0e6*rho(i,k) - !IF(qi(i,k)>1.E-8)clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.) + !clouds5(i,k)=MAX(139.7 + 1.76*Tc + 13.49*LOG(iwc), 20.) !calculate the ice water path using additional BL clouds clouds4(i,k) = max(0.0, qi(i,k) * gfac * delp(i,k)) @@ -229,7 +229,7 @@ subroutine sgscloud_radpre_run( & 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.) + clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.) !calculate the snow water path using additional BL clouds clouds8(i,k) = max(0.0, qs(i,k) * gfac * delp(i,k)) diff --git a/physics/sgscloud_radpre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta similarity index 98% rename from physics/sgscloud_radpre.meta rename to physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta index d5341bcd4..a9635efa5 100644 --- a/physics/sgscloud_radpre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sgscloud_radpre.meta @@ -1,7 +1,10 @@ [ccpp-table-properties] name = sgscloud_radpre type = scheme - dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_clouds.f,module_mp_thompson.F90 + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F + dependencies = hooks/physcons.F90,Radiation/RRTMG/radcons.f90 + dependencies = Radiation/radiation_clouds.f,MP/Thompson/module_mp_thompson.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_MP_FER_HIRES.F90 b/physics/MP/Ferrier_Aligo/module_MP_FER_HIRES.F90 similarity index 100% rename from physics/module_MP_FER_HIRES.F90 rename to physics/MP/Ferrier_Aligo/module_MP_FER_HIRES.F90 diff --git a/physics/mp_fer_hires.F90 b/physics/MP/Ferrier_Aligo/mp_fer_hires.F90 similarity index 100% rename from physics/mp_fer_hires.F90 rename to physics/MP/Ferrier_Aligo/mp_fer_hires.F90 diff --git a/physics/mp_fer_hires.meta b/physics/MP/Ferrier_Aligo/mp_fer_hires.meta similarity index 99% rename from physics/mp_fer_hires.meta rename to physics/MP/Ferrier_Aligo/mp_fer_hires.meta index 9f7c63d4d..0f7be213e 100644 --- a/physics/mp_fer_hires.meta +++ b/physics/MP/Ferrier_Aligo/mp_fer_hires.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_fer_hires type = scheme - dependencies = machine.F,module_MP_FER_HIRES.F90 + dependencies = ../../hooks/machine.F,module_MP_FER_HIRES.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFDL_parse_tracers.F90 b/physics/MP/GFDL/GFDL_parse_tracers.F90 similarity index 100% rename from physics/GFDL_parse_tracers.F90 rename to physics/MP/GFDL/GFDL_parse_tracers.F90 diff --git a/physics/fv_sat_adj.F90 b/physics/MP/GFDL/fv_sat_adj.F90 similarity index 100% rename from physics/fv_sat_adj.F90 rename to physics/MP/GFDL/fv_sat_adj.F90 diff --git a/physics/fv_sat_adj.meta b/physics/MP/GFDL/fv_sat_adj.meta similarity index 98% rename from physics/fv_sat_adj.meta rename to physics/MP/GFDL/fv_sat_adj.meta index 5cdc96358..c91e438b7 100644 --- a/physics/fv_sat_adj.meta +++ b/physics/MP/GFDL/fv_sat_adj.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = fv_sat_adj type = scheme - dependencies = machine.F,module_gfdl_cloud_microphys.F90,module_mp_radar.F90,multi_gases.F90,physcons.F90 + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = module_gfdl_cloud_microphys.F90,multi_gases.F90 + dependencies = ../module_mp_radar.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/MP/GFDL/gfdl_cloud_microphys.F90 similarity index 100% rename from physics/gfdl_cloud_microphys.F90 rename to physics/MP/GFDL/gfdl_cloud_microphys.F90 diff --git a/physics/gfdl_cloud_microphys.meta b/physics/MP/GFDL/gfdl_cloud_microphys.meta similarity index 99% rename from physics/gfdl_cloud_microphys.meta rename to physics/MP/GFDL/gfdl_cloud_microphys.meta index 5e752b473..719a340e5 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/MP/GFDL/gfdl_cloud_microphys.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = gfdl_cloud_microphys type = scheme - dependencies = machine.F,module_mp_radar.F90,module_gfdl_cloud_microphys.F90 + dependencies = ../../hooks/machine.F + dependencies = ../module_mp_radar.F90 + dependencies = module_gfdl_cloud_microphys.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_gfdl_cloud_microphys.F90 b/physics/MP/GFDL/module_gfdl_cloud_microphys.F90 similarity index 100% rename from physics/module_gfdl_cloud_microphys.F90 rename to physics/MP/GFDL/module_gfdl_cloud_microphys.F90 diff --git a/physics/multi_gases.F90 b/physics/MP/GFDL/multi_gases.F90 similarity index 100% rename from physics/multi_gases.F90 rename to physics/MP/GFDL/multi_gases.F90 diff --git a/physics/aer_cloud.F b/physics/MP/Morrison_Gettelman/aer_cloud.F similarity index 100% rename from physics/aer_cloud.F rename to physics/MP/Morrison_Gettelman/aer_cloud.F diff --git a/physics/aerclm_def.F b/physics/MP/Morrison_Gettelman/aerclm_def.F similarity index 100% rename from physics/aerclm_def.F rename to physics/MP/Morrison_Gettelman/aerclm_def.F diff --git a/physics/aerinterp.F90 b/physics/MP/Morrison_Gettelman/aerinterp.F90 similarity index 99% rename from physics/aerinterp.F90 rename to physics/MP/Morrison_Gettelman/aerinterp.F90 index 4e2dc9047..fcfe29607 100644 --- a/physics/aerinterp.F90 +++ b/physics/MP/Morrison_Gettelman/aerinterp.F90 @@ -426,7 +426,7 @@ SUBROUTINE aerinterpol( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, ENDDO else DO k=1, levsaer-1 !! from sfc to toa - IF(prsl(j,L) < aerpres(j,k) .and. prsl(j,L)>aerpres(j,k+1)) then + IF(prsl(j,L) <= aerpres(j,k) .and. prsl(j,L)>aerpres(j,k+1)) then i1 = k i2 = min(k+1,levsaer) exit diff --git a/physics/cldmacro.F b/physics/MP/Morrison_Gettelman/cldmacro.F similarity index 100% rename from physics/cldmacro.F rename to physics/MP/Morrison_Gettelman/cldmacro.F diff --git a/physics/cldwat2m_micro.F b/physics/MP/Morrison_Gettelman/cldwat2m_micro.F similarity index 100% rename from physics/cldwat2m_micro.F rename to physics/MP/Morrison_Gettelman/cldwat2m_micro.F diff --git a/physics/m_micro.F90 b/physics/MP/Morrison_Gettelman/m_micro.F90 similarity index 100% rename from physics/m_micro.F90 rename to physics/MP/Morrison_Gettelman/m_micro.F90 diff --git a/physics/m_micro.meta b/physics/MP/Morrison_Gettelman/m_micro.meta similarity index 99% rename from physics/m_micro.meta rename to physics/MP/Morrison_Gettelman/m_micro.meta index a9b5ec4db..16efc5cc4 100644 --- a/physics/m_micro.meta +++ b/physics/MP/Morrison_Gettelman/m_micro.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = m_micro type = scheme - dependencies = aer_cloud.F,aerclm_def.F,cldmacro.F,cldwat2m_micro.F,machine.F,micro_mg_utils.F90,micro_mg2_0.F90,micro_mg3_0.F90,physcons.F90,wv_saturation.F,machine.F + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 + dependencies = aer_cloud.F,aerclm_def.F,cldmacro.F,cldwat2m_micro.F + dependencies = micro_mg_utils.F90,micro_mg2_0.F90,micro_mg3_0.F90,wv_saturation.F ######################################################################## [ccpp-arg-table] diff --git a/physics/m_micro_post.F90 b/physics/MP/Morrison_Gettelman/m_micro_post.F90 similarity index 100% rename from physics/m_micro_post.F90 rename to physics/MP/Morrison_Gettelman/m_micro_post.F90 diff --git a/physics/m_micro_post.meta b/physics/MP/Morrison_Gettelman/m_micro_post.meta similarity index 99% rename from physics/m_micro_post.meta rename to physics/MP/Morrison_Gettelman/m_micro_post.meta index 684ac3f21..88a4325e7 100644 --- a/physics/m_micro_post.meta +++ b/physics/MP/Morrison_Gettelman/m_micro_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = m_micro_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/m_micro_pre.F90 b/physics/MP/Morrison_Gettelman/m_micro_pre.F90 similarity index 100% rename from physics/m_micro_pre.F90 rename to physics/MP/Morrison_Gettelman/m_micro_pre.F90 diff --git a/physics/m_micro_pre.meta b/physics/MP/Morrison_Gettelman/m_micro_pre.meta similarity index 99% rename from physics/m_micro_pre.meta rename to physics/MP/Morrison_Gettelman/m_micro_pre.meta index 7ac592833..b8cd2ac32 100644 --- a/physics/m_micro_pre.meta +++ b/physics/MP/Morrison_Gettelman/m_micro_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = m_micro_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/micro_mg2_0.F90 b/physics/MP/Morrison_Gettelman/micro_mg2_0.F90 similarity index 100% rename from physics/micro_mg2_0.F90 rename to physics/MP/Morrison_Gettelman/micro_mg2_0.F90 diff --git a/physics/micro_mg3_0.F90 b/physics/MP/Morrison_Gettelman/micro_mg3_0.F90 similarity index 100% rename from physics/micro_mg3_0.F90 rename to physics/MP/Morrison_Gettelman/micro_mg3_0.F90 diff --git a/physics/micro_mg_utils.F90 b/physics/MP/Morrison_Gettelman/micro_mg_utils.F90 similarity index 100% rename from physics/micro_mg_utils.F90 rename to physics/MP/Morrison_Gettelman/micro_mg_utils.F90 diff --git a/physics/wv_saturation.F b/physics/MP/Morrison_Gettelman/wv_saturation.F similarity index 100% rename from physics/wv_saturation.F rename to physics/MP/Morrison_Gettelman/wv_saturation.F diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/MP/NSSL/module_mp_nssl_2mom.F90 similarity index 100% rename from physics/module_mp_nssl_2mom.F90 rename to physics/MP/NSSL/module_mp_nssl_2mom.F90 diff --git a/physics/mp_nssl.F90 b/physics/MP/NSSL/mp_nssl.F90 similarity index 93% rename from physics/mp_nssl.F90 rename to physics/MP/NSSL/mp_nssl.F90 index e79376709..0b111f7cd 100644 --- a/physics/mp_nssl.F90 +++ b/physics/MP/NSSL/mp_nssl.F90 @@ -15,6 +15,7 @@ module mp_nssl private logical :: is_initialized = .False. + logical :: missing_vars_global = .False. real :: nssl_qccn contains @@ -26,7 +27,9 @@ module mp_nssl !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & - mpirank, mpiroot, & + mpirank, mpiroot,mpicomm, & + qc, qr, qi, qs, qh, & + ccw, crw, cci, csw, chw, vh, & con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps, & imp_physics, imp_physics_nssl, & @@ -36,6 +39,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const +#ifdef MPI + use mpi +#endif implicit none @@ -50,16 +56,32 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: mpirank integer, intent(in) :: mpiroot + integer, intent(in) :: mpicomm integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0 logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment + real(kind_phys), intent(inout) :: qc (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qr (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qi (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qh (:,:) !(1:ncol,1:nlev) graupel + real(kind_phys), intent(inout) :: ccw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: crw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cci(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: csw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: chw(:,:) !(1:ncol,1:nlev) graupel number + real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume + ! Local variables: dimensions used in nssl_init integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k - real :: nssl_params(20) + real(kind_phys) :: nssl_params(20) integer :: ihailv,ipc + real(kind_phys), parameter :: qmin = 1.e-12 + integer :: ierr + logical :: missing_vars = .False. ! Initialize the CCPP error handling variables @@ -143,6 +165,19 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! For restart runs, the init is done here if (restart) then + + ! For restart, check if the IC is from a different scheme that does not have all the needed variables + missing_vars = .False. + IF ( Any( qc > qmin .and. ccw == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qi > qmin .and. cci == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qs > qmin .and. csw == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qr > qmin .and. crw == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qh > qmin .and. (chw == 0.0 .or. vh == 0.0) ) ) missing_vars = .true. + +#ifdef MPI + call MPI_Allreduce(missing_vars, missing_vars_global, 1, MPI_LOGICAL, MPI_LOR, mpicomm, ierr) +#endif + is_initialized = .true. return end if @@ -312,13 +347,14 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & its,ite, jts,jte, kts,kte, i,j,k integer :: itimestep ! timestep counter integer :: ntmul, n - real, parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) + real(kind_phys), parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 logical :: invertccn - real :: cwmas + real(kind_phys) :: cwmas real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array + errflg = 0 @@ -529,8 +565,8 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & dtptmp = dtp ntmul = 1 ENDIF - - IF ( first_time_step .and. .not. restart ) THEN + + IF ( first_time_step .and. ( .not. restart .or. missing_vars_global ) ) THEN itimestep = 0 ! gets incremented to 1 in call loop IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN diff --git a/physics/mp_nssl.meta b/physics/MP/NSSL/mp_nssl.meta similarity index 86% rename from physics/mp_nssl.meta rename to physics/MP/NSSL/mp_nssl.meta index 337b1ab76..8449f26cf 100644 --- a/physics/mp_nssl.meta +++ b/physics/MP/NSSL/mp_nssl.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_nssl type = scheme - dependencies = machine.F,module_mp_nssl_2mom.F90 + dependencies = ../../hooks/machine.F,module_mp_nssl_2mom.F90 [ccpp-arg-table] name = mp_nssl_init @@ -63,6 +63,101 @@ dimensions = () type = integer intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[qc] + standard_name = cloud_liquid_water_mixing_ratio + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension ,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qr] + standard_name = rain_mixing_ratio + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qi] + standard_name = cloud_ice_mixing_ratio + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qs] + standard_name = snow_mixing_ratio + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qh] + standard_name = graupel_mixing_ratio + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ccw] + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[crw] + standard_name = mass_number_concentration_of_rain_water_in_air + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cci] + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[csw] + standard_name = mass_number_concentration_of_snow_in_air + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[chw] + standard_name = mass_number_concentration_of_graupel_in_air + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vh] + standard_name = graupel_volume + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration diff --git a/physics/module_mp_thompson.F90 b/physics/MP/Thompson/module_mp_thompson.F90 similarity index 98% rename from physics/module_mp_thompson.F90 rename to physics/MP/Thompson/module_mp_thompson.F90 index 271db11d0..44e552160 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/MP/Thompson/module_mp_thompson.F90 @@ -993,6 +993,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod, evapprod, & #endif refl_10cm, diagflag, do_radar_ref, & + max_hail_diam_sfc, & vt_dbz_wt, first_time_step, & re_cloud, re_ice, re_snow, & has_reqc, has_reqi, has_reqs, & @@ -1062,6 +1063,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & GRAUPELNC, GRAUPELNCV REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & refl_10cm + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & + max_hail_diam_sfc REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & vt_dbz_wt LOGICAL, INTENT(IN) :: first_time_step @@ -1416,6 +1419,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qcten1(k) = 0. endif initialize_extended_diagnostics enddo + lsml = lsm(i,j) if (is_aerosol_aware .or. merra2_aerosol_aware) then do k = kts, kte nc1d(k) = nc(i,k,j) @@ -1423,7 +1427,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nifa1d(k) = nifa(i,k,j) enddo else - lsml = lsm(i,j) do k = kts, kte if(lsml == 1) then nc1d(k) = Nt_c_l/rho(k) @@ -1679,6 +1682,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & (nsteps>1 .and. istep==nsteps) .or. & (nsteps==1 .and. ndt==1)) THEN + max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d) + !> - Call calc_refl10cm() diagflag_present: IF ( PRESENT (diagflag) ) THEN @@ -2464,17 +2469,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 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 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo - + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -3541,17 +3536,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - do k = kte, kts, -1 - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 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 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo - + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -3589,7 +3574,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION if (clap .gt. eps) then if (is_aerosol_aware .or. merra2_aerosol_aware) then - xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k))) + xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml)) else if(lsml == 1) then xnc = Nt_c_l @@ -5366,14 +5351,15 @@ end subroutine table_ccnAct ! TO_DO ITEM: For radiation cooling producing fog, in which case the !.. updraft velocity could easily be negative, we could use the temp !.. and its tendency to diagnose a pretend postive updraft velocity. - real function activ_ncloud(Tt, Ww, NCCN) + real function activ_ncloud(Tt, Ww, NCCN, lsm_in) implicit none REAL, INTENT(IN):: Tt, Ww, NCCN + INTEGER, INTENT(IN):: lsm_in REAL:: n_local, w_local INTEGER:: i, j, k, l, m, n REAL:: A, B, C, D, t, u, x1, x2, y1, y2, nx, wy, fraction - + REAL:: lower_lim_nuc_frac ! ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) ntb_arc ! ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) ntb_arw @@ -5420,6 +5406,14 @@ real function activ_ncloud(Tt, Ww, NCCN) l = 3 m = 2 + if (lsm_in .eq. 1) then ! land + lower_lim_nuc_frac = 0. + else if (lsm_in .eq. 0) then ! water + lower_lim_nuc_frac = 0.15 + else + lower_lim_nuc_frac = 0.15 ! catch-all for anything else + endif + A = tnccn_act(i-1,j-1,k,l,m) B = tnccn_act(i,j-1,k,l,m) C = tnccn_act(i,j,k,l,m) @@ -5434,7 +5428,8 @@ real function activ_ncloud(Tt, Ww, NCCN) ! u = (w_local-ta_Ww(j-1))/(ta_Ww(j)-ta_Ww(j-1)) fraction = (1.0-t)*(1.0-u)*A + t*(1.0-u)*B + t*u*C + (1.0-t)*u*D - + fraction = MAX(fraction, lower_lim_nuc_frac) + ! if (NCCN*fraction .gt. 0.75*Nt_c_max) then ! write(*,*) ' DEBUG-GT ', n_local, w_local, Tt, i, j, k ! endif @@ -6085,16 +6080,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 - 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 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -6471,6 +6457,88 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1) END SUBROUTINE semi_lagrange_sedim +!>\ingroup aathompson +!! @brief Calculates graupel size distribution parameters +!! +!! Calculates graupel intercept and slope parameters for +!! for a vertical column +!! +!! @param[in] kts integer start index for vertical column +!! @param[in] kte integer end index for vertical column +!! @param[in] rand1 real random number for stochastic physics +!! @param[in] rg real array, size(kts:kte) for graupel mass concentration [kg m^3] +!! @param[out] ilamg double array, size(kts:kte) for inverse graupel slope parameter [m] +!! @param[out] N0_g double array, size(kts:kte) for graupel intercept paramter [m-4] +subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) + + implicit none + + integer, intent(in) :: kts, kte + real, intent(in) :: rand1 + real, intent(in) :: rg(:) + double precision, intent(out) :: ilamg(:), N0_g(:) + + integer :: k + real :: ygra1, zans1 + double precision :: N0_exp, lam_exp, lamg + + do k = kte, kts, -1 + ygra1 = alog10(max(1.e-9, rg(k))) + zans1 = 3.4 + 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 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + ilamg(k) = 1./lamg + N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + enddo + +end subroutine graupel_psd_parameters + +!>\ingroup aathompson +!! @brief Calculates graupel/hail maximum diameter +!! +!! Calculates graupel/hail maximum diameter (currently the 99th percentile of mass distribtuion) +!! for a vertical column +!! +!! @param[in] kts integer start index for vertical column +!! @param[in] kte integer end index for vertical column +!! @param[in] qg real array, size(kts:kte) for graupel mass mixing ratio [kg kg^-1] +!! @param[in] temperature double array, size(kts:kte) temperature [K] +!! @param[in] pressure double array, size(kts:kte) pressure [Pa] +!! @param[in] qv real array, size(kts:kte) water vapor mixing ratio [kg kg^-1] +!! @param[out] max_hail_diam real maximum hail diameter [m] +function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) result(max_hail_diam) + + implicit none + + integer, intent(in) :: kts, kte + real, intent(in) :: qg(:), temperature(:), pressure(:), qv(:) + real :: max_hail_diam + + integer :: k + real :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte) + double precision :: ilamg(kts:kte), N0_g(kts:kte) + real, parameter :: random_number = 0. + + max_hail_column = 0. + rg = 0. + do k = kts, kte + rho(k) = 0.622*pressure(k)/(R*temperature(k)*(max(1.e-10, qv(k))+0.622)) + if (qg(k) .gt. R1) then + rg(k) = qg(k)*rho(k) + else + rg(k) = R1 + endif + enddo + + call graupel_psd_parameters(kts, kte, random_number, rg, ilamg, N0_g) + + where(rg .gt. 1.e-9) max_hail_column = 10.05 * ilamg + max_hail_diam = max_hail_column(kts) + +end function hail_mass_99th_percentile + !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ END MODULE module_mp_thompson diff --git a/physics/module_mp_thompson_make_number_concentrations.F90 b/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 similarity index 100% rename from physics/module_mp_thompson_make_number_concentrations.F90 rename to physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 diff --git a/physics/mp_thompson.F90 b/physics/MP/Thompson/mp_thompson.F90 similarity index 99% rename from physics/mp_thompson.F90 rename to physics/MP/Thompson/mp_thompson.F90 index c456e87cd..7b5b83b37 100644 --- a/physics/mp_thompson.F90 +++ b/physics/MP/Thompson/mp_thompson.F90 @@ -329,6 +329,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & first_time_step, istep, nsteps, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, fullradar_diag, & + max_hail_diam_sfc, & do_radar_ref, aerfld, & mpicomm, mpirank, mpiroot, blkno, & ext_diag, diag3d, reset_diag3d, & @@ -387,6 +388,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent( out) :: sr(:) ! Radar reflectivity real(kind_phys), intent(inout) :: refl_10cm(:,:) + real(kind_phys), intent(inout) :: max_hail_diam_sfc(:) logical, intent(in ) :: do_radar_ref logical, intent(in) :: sedi_semi integer, intent(in) :: decfl @@ -698,6 +700,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & aero_ind_fdb=aero_ind_fdb, rand_perturb_on=spp_mp_opt, & kme_stoch=kme_stoch, & @@ -738,6 +741,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & diff --git a/physics/mp_thompson.meta b/physics/MP/Thompson/mp_thompson.meta similarity index 98% rename from physics/mp_thompson.meta rename to physics/MP/Thompson/mp_thompson.meta index 5918e4dd9..ffe34bafb 100644 --- a/physics/mp_thompson.meta +++ b/physics/MP/Thompson/mp_thompson.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = mp_thompson type = scheme - dependencies = machine.F,module_mp_radar.F90,module_mp_thompson.F90,module_mp_thompson_make_number_concentrations.F90 + dependencies = ../../hooks/machine.F + dependencies = ../module_mp_radar.F90 + dependencies = module_mp_thompson.F90,module_mp_thompson_make_number_concentrations.F90 ######################################################################## [ccpp-arg-table] @@ -610,6 +612,14 @@ type = real kind = kind_phys intent = out +[max_hail_diam_sfc] + standard_name = max_hail_diameter_sfc + long_name = instantaneous maximum hail diameter at lowest model level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [fullradar_diag] standard_name = do_full_radar_reflectivity long_name = flag for computing full radar reflectivity diff --git a/physics/mp_thompson_post.F90 b/physics/MP/Thompson/mp_thompson_post.F90 similarity index 100% rename from physics/mp_thompson_post.F90 rename to physics/MP/Thompson/mp_thompson_post.F90 diff --git a/physics/mp_thompson_post.meta b/physics/MP/Thompson/mp_thompson_post.meta similarity index 98% rename from physics/mp_thompson_post.meta rename to physics/MP/Thompson/mp_thompson_post.meta index 82b035e99..43e89b29c 100644 --- a/physics/mp_thompson_post.meta +++ b/physics/MP/Thompson/mp_thompson_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_thompson_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/mp_thompson_pre.F90 b/physics/MP/Thompson/mp_thompson_pre.F90 similarity index 100% rename from physics/mp_thompson_pre.F90 rename to physics/MP/Thompson/mp_thompson_pre.F90 diff --git a/physics/mp_thompson_pre.meta b/physics/MP/Thompson/mp_thompson_pre.meta similarity index 97% rename from physics/mp_thompson_pre.meta rename to physics/MP/Thompson/mp_thompson_pre.meta index 12e812bb3..563eb2809 100644 --- a/physics/mp_thompson_pre.meta +++ b/physics/MP/Thompson/mp_thompson_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mp_thompson_pre type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/zhaocarr_gscond.f b/physics/MP/Zhao_Carr/zhaocarr_gscond.f similarity index 100% rename from physics/zhaocarr_gscond.f rename to physics/MP/Zhao_Carr/zhaocarr_gscond.f diff --git a/physics/zhaocarr_gscond.meta b/physics/MP/Zhao_Carr/zhaocarr_gscond.meta similarity index 98% rename from physics/zhaocarr_gscond.meta rename to physics/MP/Zhao_Carr/zhaocarr_gscond.meta index 493397722..ed57ca909 100644 --- a/physics/zhaocarr_gscond.meta +++ b/physics/MP/Zhao_Carr/zhaocarr_gscond.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = zhaocarr_gscond type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/zhaocarr_precpd.f b/physics/MP/Zhao_Carr/zhaocarr_precpd.f similarity index 100% rename from physics/zhaocarr_precpd.f rename to physics/MP/Zhao_Carr/zhaocarr_precpd.f diff --git a/physics/zhaocarr_precpd.meta b/physics/MP/Zhao_Carr/zhaocarr_precpd.meta similarity index 98% rename from physics/zhaocarr_precpd.meta rename to physics/MP/Zhao_Carr/zhaocarr_precpd.meta index 67f1a530b..86e6c7d67 100644 --- a/physics/zhaocarr_precpd.meta +++ b/physics/MP/Zhao_Carr/zhaocarr_precpd.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = zhaocarr_precpd type = scheme - dependencies = funcphys.f90,machine.F,physcons.F90 + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/calpreciptype.f90 b/physics/MP/calpreciptype.f90 similarity index 100% rename from physics/calpreciptype.f90 rename to physics/MP/calpreciptype.f90 diff --git a/physics/module_mp_radar.F90 b/physics/MP/module_mp_radar.F90 similarity index 100% rename from physics/module_mp_radar.F90 rename to physics/MP/module_mp_radar.F90 diff --git a/physics/hedmf.f b/physics/PBL/HEDMF/hedmf.f similarity index 100% rename from physics/hedmf.f rename to physics/PBL/HEDMF/hedmf.f diff --git a/physics/hedmf.meta b/physics/PBL/HEDMF/hedmf.meta similarity index 99% rename from physics/hedmf.meta rename to physics/PBL/HEDMF/hedmf.meta index c2d873065..be0c83741 100644 --- a/physics/hedmf.meta +++ b/physics/PBL/HEDMF/hedmf.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = hedmf type = scheme - dependencies = funcphys.f90,machine.F,mfpbl.f,physcons.F90,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../../hooks/physcons.F90,../mfpbl.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/module_BL_MYJPBL.F90 b/physics/PBL/MYJ/module_BL_MYJPBL.F90 similarity index 100% rename from physics/module_BL_MYJPBL.F90 rename to physics/PBL/MYJ/module_BL_MYJPBL.F90 diff --git a/physics/myjpbl_wrapper.F90 b/physics/PBL/MYJ/myjpbl_wrapper.F90 similarity index 100% rename from physics/myjpbl_wrapper.F90 rename to physics/PBL/MYJ/myjpbl_wrapper.F90 diff --git a/physics/myjpbl_wrapper.meta b/physics/PBL/MYJ/myjpbl_wrapper.meta similarity index 99% rename from physics/myjpbl_wrapper.meta rename to physics/PBL/MYJ/myjpbl_wrapper.meta index 427088b86..281396eed 100644 --- a/physics/myjpbl_wrapper.meta +++ b/physics/PBL/MYJ/myjpbl_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = myjpbl_wrapper type = scheme - dependencies = module_BL_MYJPBL.F90 + dependencies = ../../hooks/machine.F,module_BL_MYJPBL.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/bl_mynn_common.f90 b/physics/PBL/MYNN_EDMF/bl_mynn_common.f90 similarity index 100% rename from physics/bl_mynn_common.f90 rename to physics/PBL/MYNN_EDMF/bl_mynn_common.f90 diff --git a/physics/module_bl_mynn.F90 b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 similarity index 85% rename from physics/module_bl_mynn.F90 rename to physics/PBL/MYNN_EDMF/module_bl_mynn.F90 index ec6b5700d..cc7a47ce6 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 @@ -232,6 +232,18 @@ ! bl_mynn_cloudpdf = 2 (Chab-Becht). ! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. +! v4.5.2 / CCPP +! Some code optimization. Removed many conditions from loops. Redesigned the mass- +! flux scheme to use 8 plumes instead of a variable n plumes. This results in +! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume. +! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all +! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility +! for tuning near-surface cloud fractions to remove excess fog/low ceilings. +! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This +! results in a change in the pre-radiation code to no longer multiply mixing ratios +! by cloud fractions. +! Lots of code cleanup: removal of test code, comments, changing text case, etc. +! Many misc tuning/tweaks. ! ! Many of these changes are now documented in references listed above. !==================================================================== @@ -256,11 +268,11 @@ MODULE module_bl_mynn !=================================================================== ! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. - real(kind_phys), PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & + real(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, & cphh_st=5.0, cphh_unst=16.0 ! Closure constants - real(kind_phys), PARAMETER :: & + real(kind_phys), parameter :: & &pr = 0.74, & &g1 = 0.235, & ! NN2009 = 0.235 &b1 = 24.0, & @@ -275,7 +287,7 @@ MODULE module_bl_mynn &a2 = a1*( g1-c1 )/( g1*pr ), & &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - real(kind_phys), PARAMETER :: & + real(kind_phys), parameter :: & &cc2 = 1.0-c2, & &cc3 = 1.0-c3, & &e1c = 3.0*a2*b2*cc3, & @@ -286,15 +298,15 @@ MODULE module_bl_mynn ! Constants for min tke in elt integration (qmin), max z/L in els (zmax), ! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): - real(kind_phys), PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 + real(kind_phys), parameter :: qmin=0.0, zmax=1.0, Sqfac=3.0 ! Note that the following mixing-length constants are now specified in mym_length ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 - real(kind_phys), PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 - real(kind_phys), PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq + real(kind_phys), parameter :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) - real(kind_phys), PARAMETER :: rr2=0.7071068, rrp=0.3989423 + real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423 !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the @@ -304,35 +316,35 @@ MODULE module_bl_mynn !!(above) back to NN2009 values (see commented out lines next to the !!parameters above). This only removes the negative TKE problem !!but does not necessarily improve performance - neutral impact. - real(kind_phys), PARAMETER :: CKmod=1. + real(kind_phys), parameter :: CKmod=1. !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts !!on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function !!for TKE in the upper PBL/cloud layer. - real(kind_phys), PARAMETER :: scaleaware=1. + real(kind_phys), parameter :: scaleaware=1. !>Of the following the options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling - INTEGER, PARAMETER :: bl_mynn_topdown = 0 + integer, parameter :: bl_mynn_topdown = 0 !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active) - INTEGER, PARAMETER :: bl_mynn_edmf_dd = 0 + integer, parameter :: bl_mynn_edmf_dd = 0 !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0) - INTEGER, PARAMETER :: dheat_opt = 1 + integer, parameter :: dheat_opt = 1 !Option to activate environmental subsidence in mass-flux scheme - LOGICAL, PARAMETER :: env_subs = .false. + logical, parameter :: env_subs = .false. !Option to switch flux-profile relationship for surface (from Puhales et al. 2020) !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE - INTEGER, PARAMETER :: bl_mynn_stfunc = 1 + integer, parameter :: bl_mynn_stfunc = 1 !option to print out more stuff for debugging purposes - LOGICAL, PARAMETER :: debug_code = .false. - INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out + logical, parameter :: debug_code = .false. + integer, parameter :: idbg = 23 !specific i-point to write out ! Used in WRF-ARW module_physics_init.F - INTEGER :: mynn_level + integer :: mynn_level CONTAINS @@ -388,7 +400,8 @@ SUBROUTINE mynn_bl_driver( & &edmf_thl,edmf_ent,edmf_qc, & &sub_thl3D,sub_sqv3D, & &det_thl3D,det_sqv3D, & - &nupdraft,maxMF,ktop_plume, & + &maxwidth,maxMF,ztop_plume, & + &ktop_plume, & &spp_pbl,pattern_spp_pbl, & &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & @@ -401,30 +414,30 @@ SUBROUTINE mynn_bl_driver( & !------------------------------------------------------------------- - INTEGER, INTENT(in) :: initflag + integer, intent(in) :: initflag !INPUT NAMELIST OPTIONS: - LOGICAL, INTENT(in) :: restart,cycling - INTEGER, INTENT(in) :: tke_budget - INTEGER, INTENT(in) :: bl_mynn_cloudpdf - INTEGER, INTENT(in) :: bl_mynn_mixlength - INTEGER, INTENT(in) :: bl_mynn_edmf - LOGICAL, INTENT(in) :: bl_mynn_tkeadvect - INTEGER, INTENT(in) :: bl_mynn_edmf_mom - INTEGER, INTENT(in) :: bl_mynn_edmf_tke - INTEGER, INTENT(in) :: bl_mynn_mixscalars - INTEGER, INTENT(in) :: bl_mynn_output - INTEGER, INTENT(in) :: bl_mynn_cloudmix - INTEGER, INTENT(in) :: bl_mynn_mixqt - INTEGER, INTENT(in) :: icloud_bl - real(kind_phys), INTENT(in) :: closure - - LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + logical, intent(in) :: restart,cycling + integer, intent(in) :: tke_budget + integer, intent(in) :: bl_mynn_cloudpdf + integer, intent(in) :: bl_mynn_mixlength + integer, intent(in) :: bl_mynn_edmf + logical, intent(in) :: bl_mynn_tkeadvect + integer, intent(in) :: bl_mynn_edmf_mom + integer, intent(in) :: bl_mynn_edmf_tke + integer, intent(in) :: bl_mynn_mixscalars + integer, intent(in) :: bl_mynn_output + integer, intent(in) :: bl_mynn_cloudmix + integer, intent(in) :: bl_mynn_mixqt + integer, intent(in) :: icloud_bl + real(kind_phys), intent(in) :: closure + + logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & FLAG_OZONE,FLAG_QS - LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg + logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg - INTEGER, INTENT(in) :: & + integer, intent(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE @@ -444,81 +457,82 @@ 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(kind_phys), INTENT(in) :: delt - real(kind_phys), DIMENSION(:), INTENT(in) :: dx - real(kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(:), intent(in) :: dx + real(kind_phys), dimension(:,:), intent(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - real(kind_phys), DIMENSION(:,:), INTENT(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca - real(kind_phys), DIMENSION(:,:), INTENT(in):: ozone - real(kind_phys), DIMENSION(:), INTENT(in):: ust, & + real(kind_phys), dimension(:,:), intent(in):: ozone + real(kind_phys), dimension(:), intent(in):: ust, & &ch,qsfc,ps,wspd - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &rublten,rvblten,rthblten,rqvblten,rqcblten, & &rqiblten,rqsblten,rqniblten,rqncblten, & &rqnwfablten,rqnifablten,rqnbcablten - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone - real(kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten + real(kind_phys), dimension(:,:), intent(inout) :: dozone + real(kind_phys), dimension(:,:), intent(in) :: rthraten - real(kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m - real(kind_phys), DIMENSION(:), INTENT(in) :: xland, & + real(kind_phys), dimension(:,:), intent(out) :: exch_h,exch_m + real(kind_phys), dimension(:), intent(in) :: xland, & &ts,znt,hfx,qfx,uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(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) :: & +! 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(kind_phys), DIMENSION(:), INTENT(inout) :: Pblh - real(kind_phys), DIMENSION(:), INTENT(inout) :: rmol + real(kind_phys), dimension(:), intent(inout) :: Pblh + real(kind_phys), dimension(:), intent(inout) :: rmol - real(kind_phys), DIMENSION(IMS:IME) :: psig_bl,psig_shcu + real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & - &KPBL,nupdraft,ktop_plume + integer,dimension(:),intent(INOUT) :: & + &KPBL,ktop_plume - real(kind_phys), DIMENSION(:), INTENT(out) :: maxmf + real(kind_phys), dimension(:), intent(out) :: & + &maxmf,maxwidth,ztop_plume - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl + real(kind_phys), dimension(:,:), intent(inout) :: el_pbl - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when tke_budget == 0 ! 1D (local) budget arrays are used for passing between subroutines. - real(kind_phys), DIMENSION(kts:kte) :: & + real(kind_phys), dimension(kts:kte) :: & &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat - real(kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D + real(kind_phys), dimension(:,:), intent(out) :: Sh3D,Sm3D - real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & &qc_bl,qi_bl,cldfra_bl - real(kind_phys), DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D, & + real(kind_phys), 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(kind_phys), DIMENSION(:,:,:), INTENT(INOUT) :: chem3d - real(kind_phys), DIMENSION(:,:), INTENT(IN) :: vdep - real(kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + integer, intent(IN ) :: nchem, kdvel, ndvel + real(kind_phys), dimension(:,:,:), intent(INOUT) :: chem3d + real(kind_phys), dimension(:,:), intent(IN) :: vdep + real(kind_phys), dimension(:), intent(IN) :: frp,EMIS_ANT_NO !local - real(kind_phys), DIMENSION(kts:kte ,nchem) :: chem1 - real(kind_phys), DIMENSION(kts:kte+1,nchem) :: s_awchem1 - real(kind_phys), DIMENSION(ndvel) :: vd1 - INTEGER :: ic + real(kind_phys), dimension(kts:kte ,nchem) :: chem1 + real(kind_phys), dimension(kts:kte+1,nchem) :: s_awchem1 + real(kind_phys), dimension(ndvel) :: vd1 + integer :: ic !local vars - INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k,kproblem - real(kind_phys), DIMENSION(KTS:KTE) :: & + integer :: ITF,JTF,KTF, IMD,JMD + integer :: i,j,k,kproblem + real(kind_phys), dimension(kts:kte) :: & &thl,tl,qv1,qc1,qi1,qs1,sqw, & &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & - &vt, vq, sgm - real(kind_phys), DIMENSION(KTS:KTE) :: & + &vt, vq, sgm, kzero + real(kind_phys), dimension(kts:kte) :: & &thetav,sh,sm,u1,v1,w1,p1, & &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & &sqv,sqi,sqc,sqs, & @@ -527,45 +541,45 @@ SUBROUTINE mynn_bl_driver( & &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 !mass-flux variables - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, & &edmf_ent1,edmf_qc1 - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, & &edmf_ent_dd1,edmf_qc_dd1 - real(kind_phys), DIMENSION(KTS:KTE) :: & + real(kind_phys), dimension(kts:kte) :: & &sub_thl,sub_sqv,sub_u,sub_v, & &det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), DIMENSION(KTS:KTE+1) :: & + real(kind_phys), 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, & &s_awqnbca1 - real(kind_phys), DIMENSION(KTS:KTE+1) :: & + real(kind_phys), dimension(kts:kte+1) :: & &sd_aw1,sd_awthl1,sd_awqt1, & &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - real(kind_phys), DIMENSION(KTS:KTE+1) :: zw + real(kind_phys), dimension(kts:kte+1) :: zw real(kind_phys) :: 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,wsp + &th_sfc,wsp !top-down diffusion - real(kind_phys), DIMENSION(ITS:ITE) :: maxKHtopdown - real(kind_phys), DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD + real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown + real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD - LOGICAL :: INITIALIZE_QKE,problem + logical :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(IN) :: spp_pbl + real(kind_phys), dimension(:,:), intent(IN) :: pattern_spp_pbl + real(kind_phys), dimension(KTS:KTE) :: rstoch_col ! Substepping TKE - INTEGER :: nsub + integer :: nsub real(kind_phys) :: delt2 @@ -629,9 +643,11 @@ SUBROUTINE mynn_bl_driver( & !edmf_qc_dd(its:ite,kts:kte)=0. ENDIF ktop_plume(its:ite)=0 !int - nupdraft(its:ite)=0 !int + ztop_plume(its:ite)=0. + maxwidth(its:ite)=0. maxmf(its:ite)=0. maxKHtopdown(its:ite)=0. + kzero(kts:kte)=0. ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS !> - Within the MYNN-EDMF, there is a dependecy check for the first time step, @@ -740,7 +756,7 @@ SUBROUTINE mynn_bl_driver( & !keep snow out for now - increases ceiling bias sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & @@ -987,10 +1003,10 @@ SUBROUTINE mynn_bl_driver( & else zw(k)=zw(k-1)+dz(i,k-1) endif - !keep snow out for now - increases ceiling bias + !keep snow out for now - increases ceiling bias sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k) thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & @@ -1021,7 +1037,7 @@ SUBROUTINE mynn_bl_driver( & endif s_awchem1 = 0.0 -!> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ +!> - Call get_pblh() to calculate the hybrid \f$\theta_{v}-TKE\f$ !! PBL height diagnostic. CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& & Qke1,zw,dz1,xland(i),KPBL(i)) @@ -1147,8 +1163,8 @@ SUBROUTINE mynn_bl_driver( & &FLAG_QNC,FLAG_QNI, & &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & &Psig_shcu(i), & - &nupdraft(i),ktop_plume(i), & - &maxmf(i),ztop_plume, & + &maxwidth(i),ktop_plume(i), & + &maxmf(i),ztop_plume(i), & &spp_pbl,rstoch_col ) endif @@ -1220,9 +1236,9 @@ SUBROUTINE mynn_bl_driver( & call mynn_tendencies(kts,kte,i, & &delt, dz1, rho1, & &u1, v1, th1, tk1, qv1, & - &qc1, qi1, qs1, qnc1, qni1, & + &qc1, qi1, kzero, qnc1, qni1, & !kzero replaces qs1 - not mixing snow &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, sqs, sqw, & + &sqv, sqc, sqi, kzero, sqw, & !kzero replaces sqs - not mixing snow &qnwfa1, qnifa1, qnbca1, ozone1, & &ust(i),flt,flq,flqv,flqc, & &wspd(i),uoce(i),voce(i), & @@ -1295,27 +1311,27 @@ SUBROUTINE mynn_bl_driver( & &dfm, dfh, dz1, K_m1, K_h1 ) !UPDATE 3D ARRAYS - exch_m(i,:) =k_m1(:) - exch_h(i,:) =k_h1(:) - rublten(i,:) =du1(:) - rvblten(i,:) =dv1(:) - rthblten(i,:)=dth1(:) - rqvblten(i,:)=dqv1(:) + exch_m(i,kts:kte) =k_m1(kts:kte) + exch_h(i,kts:kte) =k_h1(kts:kte) + rublten(i,kts:kte) =du1(kts:kte) + rvblten(i,kts:kte) =dv1(kts:kte) + rthblten(i,kts:kte)=dth1(kts:kte) + rqvblten(i,kts:kte)=dqv1(kts:kte) if (bl_mynn_cloudmix > 0) then - if (flag_qc) rqcblten(i,:)=dqc1(:) - if (flag_qi) rqiblten(i,:)=dqi1(:) - if (flag_qs) rqsblten(i,:)=dqs1(:) + if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte) + if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte) + if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte) else if (flag_qc) rqcblten(i,:)=0. if (flag_qi) rqiblten(i,:)=0. if (flag_qs) rqsblten(i,:)=0. endif if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then - if (flag_qnc) rqncblten(i,:) =dqnc1(:) - if (flag_qni) rqniblten(i,:) =dqni1(:) - if (flag_qnwfa) rqnwfablten(i,:)=dqnwfa1(:) - if (flag_qnifa) rqnifablten(i,:)=dqnifa1(:) - if (flag_qnbca) rqnbcablten(i,:)=dqnbca1(:) + if (flag_qnc) rqncblten(i,kts:kte) =dqnc1(kts:kte) + if (flag_qni) rqniblten(i,kts:kte) =dqni1(kts:kte) + if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte) + if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte) + if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte) else if (flag_qnc) rqncblten(i,:) =0. if (flag_qni) rqniblten(i,:) =0. @@ -1323,19 +1339,19 @@ SUBROUTINE mynn_bl_driver( & if (flag_qnifa) rqnifablten(i,:)=0. if (flag_qnbca) rqnbcablten(i,:)=0. endif - dozone(i,:)=dozone1(:) + dozone(i,kts:kte)=dozone1(kts:kte) if (icloud_bl > 0) then - qc_bl(i,:) =qc_bl1D(:) - qi_bl(i,:) =qi_bl1D(:) - cldfra_bl(i,:)=cldfra_bl1D(:) + qc_bl(i,kts:kte) =qc_bl1D(kts:kte) + qi_bl(i,kts:kte) =qi_bl1D(kts:kte) + cldfra_bl(i,kts:kte)=cldfra_bl1D(kts:kte) endif - el_pbl(i,:)=el(:) - qke(i,:) =qke1(:) - tsq(i,:) =tsq1(:) - qsq(i,:) =qsq1(:) - cov(i,:) =cov1(:) - sh3d(i,:) =sh(:) - sm3d(i,:) =sm(:) + el_pbl(i,kts:kte)=el(kts:kte) + qke(i,kts:kte) =qke1(kts:kte) + tsq(i,kts:kte) =tsq1(kts:kte) + qsq(i,kts:kte) =qsq1(kts:kte) + cov(i,kts:kte) =cov1(kts:kte) + sh3d(i,kts:kte) =sh(kts:kte) + sm3d(i,kts:kte) =sm(kts:kte) if (tke_budget .eq. 1) then !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) @@ -1363,24 +1379,24 @@ SUBROUTINE mynn_bl_driver( & !update updraft/downdraft properties if (bl_mynn_output > 0) then !research mode == 1 if (bl_mynn_edmf > 0) then - edmf_a(i,:) =edmf_a1(:) - edmf_w(i,:) =edmf_w1(:) - edmf_qt(i,:) =edmf_qt1(:) - edmf_thl(i,:) =edmf_thl1(:) - edmf_ent(i,:) =edmf_ent1(:) - edmf_qc(i,:) =edmf_qc1(:) - sub_thl3D(i,:)=sub_thl(:) - sub_sqv3D(i,:)=sub_sqv(:) - det_thl3D(i,:)=det_thl(:) - det_sqv3D(i,:)=det_sqv(:) + edmf_a(i,kts:kte) =edmf_a1(kts:kte) + edmf_w(i,kts:kte) =edmf_w1(kts:kte) + edmf_qt(i,kts:kte) =edmf_qt1(kts:kte) + edmf_thl(i,kts:kte) =edmf_thl1(kts:kte) + edmf_ent(i,kts:kte) =edmf_ent1(kts:kte) + edmf_qc(i,kts:kte) =edmf_qc1(kts:kte) + sub_thl3D(i,kts:kte)=sub_thl(kts:kte) + sub_sqv3D(i,kts:kte)=sub_sqv(kts:kte) + det_thl3D(i,kts:kte)=det_thl(kts:kte) + det_sqv3D(i,kts:kte)=det_sqv(kts:kte) endif !if (bl_mynn_edmf_dd > 0) THEN - ! edmf_a_dd(i,:) =edmf_a_dd1(:) - ! edmf_w_dd(i,:) =edmf_w_dd1(:) - ! edmf_qt_dd(i,:) =edmf_qt_dd1(:) - ! edmf_thl_dd(i,:)=edmf_thl_dd1(:) - ! edmf_ent_dd(i,:)=edmf_ent_dd1(:) - ! edmf_qc_dd(i,:) =edmf_qc_dd1(:) + ! edmf_a_dd(i,kts:kte) =edmf_a_dd1(kts:kte) + ! edmf_w_dd(i,kts:kte) =edmf_w_dd1(kts:kte) + ! edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte) + ! edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte) + ! edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte) + ! edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte) !endif endif @@ -1509,27 +1525,27 @@ SUBROUTINE mym_initialize ( & ! !------------------------------------------------------------------- - integer, INTENT(IN) :: kts,kte - integer, INTENT(IN) :: bl_mynn_mixlength - logical, INTENT(IN) :: INITIALIZE_QKE -! real(kind_phys), INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - real(kind_phys), INTENT(IN) :: rmo, Psig_bl, xland - real(kind_phys), INTENT(IN) :: dx, ust, zi - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,& + integer, intent(in) :: kts,kte + integer, intent(in) :: bl_mynn_mixlength + logical, intent(in) :: INITIALIZE_QKE +! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq + real(kind_phys), intent(in) :: rmo, Psig_bl, xland + real(kind_phys), intent(in) :: dx, ust, zi + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,& &qw,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: el,qke - real(kind_phys), DIMENSION(kts:kte) :: & + real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov + real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke + real(kind_phys), dimension(kts:kte) :: & &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & &gm,gh,sm,sh,qkw,vt,vq - INTEGER :: k,l,lmax + integer :: k,l,lmax real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & &flt=0.,fltv=0.,flq=0.,tmpq - real(kind_phys), DIMENSION(kts:kte) :: theta,thetav - real(kind_phys), DIMENSION(kts:kte) :: rstoch_col - INTEGER ::spp_pbl + real(kind_phys), dimension(kts:kte) :: theta,thetav + real(kind_phys), dimension(kts:kte) :: rstoch_col + integer ::spp_pbl !> - At first ql, vt and vq are set to zero. DO k = kts,kte @@ -1706,17 +1722,17 @@ SUBROUTINE mym_level2 (kts,kte, & ! !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v, & + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte), intent(in) :: u,v, & &thl,qw,ql,vt,vq,thetav - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: & + real(kind_phys), dimension(kts:kte), intent(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh integer :: k @@ -1844,25 +1860,25 @@ SUBROUTINE mym_length ( & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw - real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,xland - real(kind_phys), INTENT(IN) :: dx,zi - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: u1,v1, & + integer, intent(in) :: bl_mynn_mixlength + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland + real(kind_phys), intent(in) :: dx,zi + real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, & &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: qkw, el - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dtv + real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el + real(kind_phys), dimension(kts:kte), intent(in) :: dtv real(kind_phys):: elt,vsc - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: theta - real(kind_phys), DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + real(kind_phys), dimension(kts:kte), intent(in) :: theta + real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE @@ -1879,22 +1895,22 @@ SUBROUTINE mym_length ( & !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - real(kind_phys), PARAMETER :: minzi = 300. !< min mixed-layer height - real(kind_phys), PARAMETER :: maxdz = 750. !< max (half) transition layer depth + real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height + real(kind_phys), parameter :: maxdz = 750. !< max (half) transition layer depth !! =0.3*2500 m PBLH, so the transition !! layer stops growing for PBLHs > 2.5 km. - real(kind_phys), PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth + real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - real(kind_phys), PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) - real(kind_phys), PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) + real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m) + real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1) - INTEGER :: i,j,k + integer :: i,j,k real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les - real(kind_phys), PARAMETER :: ctau = 1000. !constant for tau_cloud + real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud ! tv0 = 0.61*tref ! gtr = 9.81/tref @@ -1985,9 +2001,9 @@ SUBROUTINE mym_length ( & uonset= 15. wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) cns = 2.7 !was 3.5 - alp1 = 0.22 + alp1 = 0.23 alp2 = 0.3 - alp3 = 2.0 * wt_u !taper off bouyancy enhancement in shear-driven pbls + alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls alp4 = 5.0 alp5 = 0.3 alp6 = 50. @@ -2043,12 +2059,12 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - bv = max( sqrt( gtr*dtv(k) ), 0.001) + bv = max( sqrt( gtr*dtv(k) ), 0.0001) 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.80 * qkw(k)/bv + elf = 1.0 * qkw(k)/bv elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 @@ -2068,8 +2084,10 @@ SUBROUTINE mym_length ( & !add blending to use BouLac mixing length in free atmos; !defined relative to the PBLH (zi) + transition layer (h1) !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - !try squared-blending - el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + !try squared-blending - but take out elb (makes it underdiffusive) + !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + el(k) = sqrt( els**2/(1. + (els**2/elt**2))) + el(k) = min(el(k), elb) el(k) = MIN (el(k), elf) el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt @@ -2254,13 +2272,13 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) ! lb2 = the average of the length up and length down !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: k,kts,kte - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - real(kind_phys), INTENT(OUT) :: lb1,lb2 - real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw + integer, intent(in) :: k,kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), intent(out) :: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw !LOCAL VARS - INTEGER :: izz, found + integer :: izz, found real(kind_phys):: dlu,dld real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz @@ -2404,15 +2422,15 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) ! lb2 = the average of the length up and length down !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - real(kind_phys), DIMENSION(kts:kte), INTENT(OUT):: lb1,lb2 - real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw + integer, intent(in) :: kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw !LOCAL VARS - INTEGER :: iz, izz, found - real(kind_phys), DIMENSION(kts:kte) :: dlu,dld - real(kind_phys), PARAMETER :: Lmax=2000. !soft limit + integer :: iz, izz, found + real(kind_phys), dimension(kts:kte) :: dlu,dld + real(kind_phys), parameter :: Lmax=2000. !soft limit real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !print*,"IN MYNN-BouLac",kts, kte @@ -2618,40 +2636,40 @@ SUBROUTINE mym_turbulence ( & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget - real(kind_phys), INTENT(IN) :: closure - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw - real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq, & + integer, intent(in) :: bl_mynn_mixlength,tke_budget + real(kind_phys), intent(in) :: closure + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq, & &Psig_bl,Psig_shcu,xland,dx,zi - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw, & + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, & &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & &TKEprodTD - real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq, & + real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, & &pdk,pdt,pdq,pdc,tcd,qcd,el - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: & + real(kind_phys), dimension(kts:kte), intent(inout) :: & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp - real(kind_phys), DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh - INTEGER :: k + integer :: k ! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh real(kind_phys):: cldavg - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: theta + real(kind_phys), dimension(kts:kte), intent(in) :: theta real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod @@ -2664,10 +2682,10 @@ SUBROUTINE mym_turbulence ( & DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col real(kind_phys):: Prnum, shb - real(kind_phys), PARAMETER :: Prlimit = 5.0 + real(kind_phys), parameter :: Prlimit = 5.0 ! ! tv0 = 0.61*tref @@ -3042,7 +3060,7 @@ SUBROUTINE mym_turbulence ( & ! q-variance (pdq), and covariance (pdc) pdk(k) = elq*( sm(k)*gm(k) & & +sh(k)*gh(k)+gamv ) + & - & TKEprodTD(k) + & 0.5*TKEprodTD(k) ! xmchen pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) pdc(k) = elh*( sh(k)*dtl(k)+gamt ) & @@ -3086,9 +3104,9 @@ SUBROUTINE mym_turbulence ( & !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE !! Buoyncy term takes the TKEprodTD(k) production now - qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered + qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen - !!!Dissipation Term (now it evaluated on mym_predict) + !!!Dissipation Term (now it evaluated in mym_predict) !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE !! >> EOB @@ -3113,8 +3131,6 @@ SUBROUTINE mym_turbulence ( & qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) END DO ! - - if (spp_pbl==1) then DO k = kts,kte dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) @@ -3181,43 +3197,43 @@ SUBROUTINE mym_predict (kts,kte, & & delt, & & dz, & & ust, flt, flq, pmz, phh, & - & el, dfq, rho, & + & el, dfq, rho, & & pdk, pdt, pdq, pdc, & & qke, tsq, qsq, cov, & & s_aw,s_awqke,bl_mynn_edmf_tke, & & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020) !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), INTENT(IN) :: closure - INTEGER, INTENT(IN) :: bl_mynn_edmf_tke,tke_budget - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - real(kind_phys), INTENT(IN) :: flt, flq, pmz, phh - real(kind_phys), INTENT(IN) :: ust, delt - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov + real(kind_phys), intent(in) :: closure + integer, intent(in) :: bl_mynn_edmf_tke,tke_budget + real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho + real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc + real(kind_phys), intent(in) :: flt, flq, pmz, phh + real(kind_phys), intent(in) :: ust, delt + real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov ! WA 8/3/15 - real(kind_phys), DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D - real(kind_phys), DIMENSION(kts:kte) :: tke_up,dzinv + real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D + real(kind_phys), dimension(kts:kte) :: tke_up,dzinv !! >> EOB - INTEGER :: k - real(kind_phys), DIMENSION(kts:kte) :: qkw, bp, rp, df3q + integer :: k + real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - real(kind_phys), DIMENSION(kts:kte) :: dtz - real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - real(kind_phys), DIMENSION(kts:kte) :: rhoinv - real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) IF (bl_mynn_edmf_tke == 0) THEN @@ -3263,7 +3279,7 @@ SUBROUTINE mym_predict (kts,kte, & kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO -!JOE-end conservation mods + !end conservation mods pdk1 = 2.0*ust**3*pmz/( vkz ) phm = 2.0/ust *phh/( vkz ) @@ -3271,8 +3287,8 @@ SUBROUTINE mym_predict (kts,kte, & pdq1 = phm*flq**2 pdc1 = phm*flt*flq ! -! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. ** - pdk(kts) = pdk1 -pdk(kts+1) +! ** pdk(1)+pdk(2) corresponds to pdk1. ** + pdk(kts) = pdk1 - pdk(kts+1) !! pdt(kts) = pdt1 -pdt(kts+1) !! pdq(kts) = pdq1 -pdq(kts+1) @@ -3367,7 +3383,7 @@ SUBROUTINE mym_predict (kts,kte, & ENDDO k=kte qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & - & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared + & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered !! >> EOBvt qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered END IF @@ -3596,39 +3612,43 @@ SUBROUTINE mym_condensation (kts,kte, & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + integer, intent(in) :: kts,kte, bl_mynn_cloudpdf #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), INTENT(IN) :: HFX1,rmo,xland - real(kind_phys), INTENT(IN) :: dx,pblh1 - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz - real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw, & + real(kind_phys), intent(in) :: HFX1,rmo,xland + real(kind_phys), intent(in) :: dx,pblh1 + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, & &qv,qc,qi,qs,tsq,qsq,cov,th - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm - real(kind_phys), DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH - real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & + real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH + real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, & &cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq real(kind_phys):: 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,q1_rh,rh_hack - real(kind_phys), PARAMETER :: rhcrit=0.83 !for hom pdf min sigma - INTEGER :: i,j,k + &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & + &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc + real(kind_phys), parameter :: qpct_sfc=0.025 + real(kind_phys), parameter :: qpct_pbl=0.030 + real(kind_phys), parameter :: qpct_trp=0.040 + real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 + real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2 + integer :: i,j,k real(kind_phys):: erf !VARIABLES FOR ALTERNATIVE SIGMA real:: dth,dtl,dqw,dzk,els - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: Sh,el + real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el !variables for SGS BL clouds real(kind_phys) :: zagl,damp,PBLH2 @@ -3636,11 +3656,11 @@ SUBROUTINE mym_condensation (kts,kte, & !JAYMES: variables for tropopause-height estimation real(kind_phys) :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo + integer :: k_tropo ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col real(kind_phys) :: qw_pert ! First, obtain an estimate for the tropopause height (k), using the method employed in the @@ -3794,29 +3814,31 @@ SUBROUTINE mym_condensation (kts,kte, & !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS !but with use of higher-order moments to estimate sigma - PBLH2=MAX(10.,PBLH1) + pblh2=MAX(10._kind_phys,pblh1) zagl = 0. + dzm1 = 0. DO k = kts,kte-1 - zagl = zagl + dz(k) - t = th(k)*exner(k) + zagl = zagl + 0.5*(dz(k) + dzm1) + dzm1 = dz(k) - xl = xl_blend(t) ! obtain latent heat - qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p - rh(k)=MAX(MIN(1.00,qw(k)/MAX(1.E-10,qsat_tk)),0.001) + t = th(k)*exner(k) + xl = xl_blend(t) ! obtain latent heat + qsat_tk= qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p + rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys) !dqw/dT: Clausius-Clapeyron - dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) + dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) alp(k) = 1.0/( 1.0+dqsl*xlvcp ) bet(k) = dqsl*exner(k) - rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) + rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b(k) = a(k)*rsl ! CB02 variable "b" + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b(k) = a(k)*rsl ! CB02 variable "b" !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) !This form of qmq (the numerator of Q1) no longer uses the a(k) factor qmq = qw_pert - qsat_tk ! saturation deficit/excess; @@ -3826,28 +3848,39 @@ SUBROUTINE mym_condensation (kts,kte, & r3sq = max( qsq(k), 0.0 ) !Calculate sigma using higher-order moments: sgm(k) = SQRT( r3sq ) - !Set limits on sigma relative to saturation water vapor + !Set constraints on sigma relative to saturation water vapor sgm(k) = min( sgm(k), qsat_tk*0.666 ) - sgm(k) = max( sgm(k), qsat_tk*0.035 ) + !sgm(k) = max( sgm(k), qsat_tk*0.035 ) + + !introduce vertical grid spacing dependence on min sgm + wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m + sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz + + !allow min sgm to vary with dz and z. + qpct = qpct_pbl*wt + qpct_trp*(1.0-wt) + qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) ) + sgm(k) = max( sgm(k), qsat_tk*qpct ) + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation !Add condition for falling/settling into low-RH layers, so at least - !some cloud fraction is applied for all qc and qi. - rh_hack = rh(k) - !ensure adequate RH & q1 when qi is at least 1e-9 - if (qi(k)>1.e-9) then - rh_hack =min(1.0, rhcrit + 0.06*(9.0 + log10(qi(k)))) + !some cloud fraction is applied for all qc, qs, and qi. + rh_hack= rh(k) + wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0) + !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) + if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 - q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) q1(k) =max(q1_rh, q1(k) ) endif - !ensure adequate RH & q1 when qc is at least 1e-6 - if (qc(k)>1.e-6) then - rh_hack =min(1.0, rhcrit + 0.09*(6.0 + log10(qc(k)))) + !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH) + if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 - q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) q1(k) =max(q1_rh, q1(k) ) endif @@ -3864,20 +3897,17 @@ SUBROUTINE mym_condensation (kts,kte, & ! 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 - 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) - ENDIF + maxqc = max(qw(k) - qsat_tk, 0.0) + if (q1k < 0.) then !unsaturated + ql_water = sgm(k)*exp(1.2*q1k-1.) + ql_ice = sgm(k)*exp(1.2*q1k-1.) + elseif (q1k > 2.) then !supersaturated + ql_water = min(sgm(k)*q1k, maxqc) + ql_ice = sgm(k)*q1k + else !slightly saturated (0 > q1 < 2) + ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc) + ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2) + endif !In saturated grid cells, use average of SGS and resolved values !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) @@ -3922,17 +3952,22 @@ SUBROUTINE mym_condensation (kts,kte, & ! Fng = 1.-1.5*q1k !ENDIF ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) - IF (q1k .GE. 1.0) THEN + if (q1k .ge. 1.0) then Fng = 1.0 - ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN - Fng = EXP(-0.4*(q1k-1.0)) - ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(q1k+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) - ENDIF + elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then + Fng = exp(-0.4*(q1k-1.0)) + elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then + Fng = 3.0 + exp(-3.8*(q1k+1.7)) + else + Fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys) + endif + + cfmax = min(cldfra_bl1D(k), 0.6_kind_phys) + !Further limit the cf going into vt & vq near the surface + zsl = min(max(25., 0.1*pblh2), 100.) + wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer + cfmax = cfmax*wt - 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 @@ -3954,7 +3989,7 @@ SUBROUTINE mym_condensation (kts,kte, & fac_damp = min(zagl * 0.0025, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) - cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.35) + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37) cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) enddo @@ -4023,17 +4058,17 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &bl_mynn_mixscalars ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i + integer, intent(in) :: kts,kte,i #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & + integer, intent(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & + logical, intent(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA ! thl - liquid water potential temperature @@ -4043,47 +4078,47 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! flq - surface flux of qw ! mass-flux plumes - real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: s_aw, & + real(kind_phys), dimension(kts:kte+1), intent(in) :: s_aw, & &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & &s_awqnwfa,s_awqnifa,s_awqnbca, & &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv ! tendencies from mass-flux environmental subsidence and detrainment - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & + real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, & &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,& + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,& &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & &cldfra_bl1d,diss_heat - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,& + real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,& &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh - real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv, & + real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, & &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone - real(kind_phys), INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce - real(kind_phys), INTENT(IN) :: ust,delt,psfc,wspd + real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce + real(kind_phys), intent(in) :: ust,delt,psfc,wspd !debugging real(kind_phys):: wsp,wsp2,tk2,th2 - LOGICAL :: problem + logical :: problem integer :: kproblem -! real(kind_phys), INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top +! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top !local vars - real(kind_phys), DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp - real(kind_phys), DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & + real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp + real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 - real(kind_phys), DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv - real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x - real(kind_phys), DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface + real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface &khdz,kmdz real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc real(kind_phys):: ustdrag,ustdiff,qvflux real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat - INTEGER :: k,kk + integer :: k,kk !Activate nonlocal mixing from the mass-flux scheme for !number concentrations and aerosols (0.0 = no; 1.0 = yes) - real(kind_phys), PARAMETER :: nonloc = 1.0 + real(kind_phys), parameter :: nonloc = 1.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -4141,38 +4176,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & -! sub_u(k)*delt + det_u(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - & - & dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & -! !!!d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & - & sub_u(k)*delt + det_u(k)*delt - ENDDO + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*uoce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff & + & + sub_u(k)*delt + det_u(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff & + & + sub_u(k)*delt + det_u(k)*delt + enddo !! no flux at the top ! a(kte)=-1. @@ -4207,37 +4237,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & -! sub_v(k)*delt + det_v(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + & - & sub_v(k)*delt + det_v(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & -! !!!d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & - & sub_v(k)*delt + det_v(k)*delt - ENDDO + b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*voce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff & + & + sub_v(k)*delt + det_v(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff & + & + sub_v(k)*delt + det_v(k)*delt + enddo !! no flux at the top ! a(kte)=-1. @@ -4586,7 +4612,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !============================================ ! MIX SNOW ( sqs ) !============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QS) THEN +!hard-code to not mix snow +IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN k=kts !rho-weighted: @@ -4813,8 +4840,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnbca(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 !qnbca2(k)=d(k-kts+1) @@ -4891,9 +4918,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & sqi2(k) = 0.0 ! if sqw2 > qsat sqc2(k) = 0.0 ENDIF - !dqv(k) = (sqv2(k) - sqv(k))/delt - !dqc(k) = (sqc2(k) - sqc(k))/delt - !dqi(k) = (sqi2(k) - sqi(k))/delt ENDDO ENDIF @@ -4902,7 +4926,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! WATER VAPOR TENDENCY !===================== DO k=kts,kte - Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + Dqv(k)=(sqv2(k) - sqv(k))/delt !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k ENDDO @@ -4913,7 +4937,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !print*,"FLAG_QC:",FLAG_QC IF (FLAG_QC) THEN DO k=kts,kte - Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt + Dqc(k)=(sqc2(k) - sqc(k))/delt !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k ENDDO ELSE @@ -4941,7 +4965,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt + Dqi(k)=(sqi2(k) - sqi(k))/delt !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k ENDDO ELSE @@ -4953,9 +4977,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== ! CLOUD SNOW TENDENCY !=================== - IF (FLAG_QS) THEN + IF (.false.) THEN !disabled DO k=kts,kte - Dqs(k)=(sqs2(k)/(1.-sqs2(k)) - qs(k))/delt + Dqs(k)=(sqs2(k) - sqs(k))/delt ENDDO ELSE DO k=kts,kte @@ -4979,10 +5003,11 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ELSE !-MIX CLOUD SPECIES? !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) DO k=kts,kte - Dqc(k)=0. + Dqc(k) =0. Dqnc(k)=0. - Dqi(k)=0. + Dqi(k) =0. Dqni(k)=0. + Dqs(k) =0. ENDDO ENDIF @@ -5207,36 +5232,36 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & enh_mix, smoke_dbg ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i - real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd - real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: rho - real(kind_phys), INTENT(IN) :: flt - real(kind_phys), INTENT(IN) :: delt,pblh - INTEGER, INTENT(IN) :: nchem, kdvel, ndvel - real(kind_phys), DIMENSION( kts:kte+1), INTENT(IN) :: s_aw - real(kind_phys), DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 - real(kind_phys), DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - real(kind_phys), DIMENSION( ndvel ), INTENT(IN) :: vd1 - real(kind_phys), INTENT(IN) :: emis_ant_no,frp - LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg + integer, intent(in) :: kts,kte,i + real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd + real(kind_phys), dimension(kts:kte), intent(inout) :: rho + real(kind_phys), intent(in) :: flt + real(kind_phys), intent(in) :: delt,pblh + integer, intent(in) :: nchem, kdvel, ndvel + real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw + real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1 + real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem + real(kind_phys), dimension( ndvel ), intent(in) :: vd1 + real(kind_phys), intent(in) :: emis_ant_no,frp + logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg !local vars - real(kind_phys), DIMENSION(kts:kte) :: dtz - real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x real(kind_phys):: rhs,dztop real(kind_phys):: t,dzk real(kind_phys):: hght real(kind_phys):: khdz_old, khdz_back - INTEGER :: k,kk,kmaxfire ! JLS 12/21/21 - INTEGER :: ic ! Chemical array loop index + integer :: k,kk,kmaxfire ! JLS 12/21/21 + integer :: ic ! Chemical array loop index - INTEGER, SAVE :: icall + integer, SAVE :: icall - real(kind_phys), DIMENSION(kts:kte) :: rhoinv - real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,khdz - real(kind_phys), PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources - real(kind_phys), PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires - real(kind_phys), PARAMETER :: pblh_threshold = 100.0 + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz + real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources + real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires + real(kind_phys), parameter :: pblh_threshold = 100.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5335,14 +5360,14 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& !------------------------------------------------------------------- - INTEGER , INTENT(in) :: kts,kte + integer , intent(in) :: kts,kte - real(kind_phys), DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh + real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh - real(kind_phys), DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h - INTEGER :: k + integer :: k real(kind_phys):: dzk K_m(kts)=0. @@ -5368,13 +5393,13 @@ SUBROUTINE tridiag(n,a,b,c,d) !------------------------------------------------------------------- - INTEGER, INTENT(in):: n - real(kind_phys), DIMENSION(n), INTENT(in) :: a,b - real(kind_phys), DIMENSION(n), INTENT(inout) :: c,d + integer, intent(in):: n + real(kind_phys), dimension(n), intent(in) :: a,b + real(kind_phys), dimension(n), intent(inout) :: c,d - INTEGER :: i + integer :: i real(kind_phys):: p - real(kind_phys), DIMENSION(n) :: q + real(kind_phys), dimension(n) :: q c(n)=0. q(1)=-c(1)/b(1) @@ -5508,23 +5533,23 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) !value could be found to work best in all conditions. !--------------------------------------------------------------- - INTEGER,INTENT(IN) :: KTS,KTE + integer,intent(in) :: KTS,KTE #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - real(kind_phys), INTENT(OUT) :: zi - real(kind_phys), INTENT(IN) :: landsea - real(kind_phys), DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - real(kind_phys), DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D + real(kind_phys), intent(out) :: zi + real(kind_phys), intent(in) :: landsea + real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D !LOCAL VARS real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point - real(kind_phys), PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). - real(kind_phys), PARAMETER :: sbl_damp = 400. !transition length for blending (m). - INTEGER :: I,J,K,kthv,ktke,kzi + real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m). + real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m). + integer :: I,J,K,kthv,ktke,kzi !Initialize KPBL (kzi) kzi = 2 @@ -5689,12 +5714,12 @@ SUBROUTINE DMP_mf( & & F_QNWFA,F_QNIFA,F_QNBCA, & & Psig_shcu, & ! output info - & nup2,ktop,maxmf,ztop, & + & maxwidth,ktop,maxmf,ztop, & ! inputs for stochastic perturbations & spp_pbl,rstoch_col ) ! inputs: - INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt + integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt #ifdef HARDCODE_VERTICAL # define kts 1 @@ -5702,133 +5727,137 @@ SUBROUTINE DMP_mf( & #endif ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: & + real(kind_phys),dimension(kts:kte), intent(in) :: & &U,V,W,TH,THL,TK,QT,QV,QC, & &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca - real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma - real(kind_phys), INTENT(IN) :: flt,fltv,flq,flqv,Psig_shcu, & + real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma + real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, & &landsea,ts,dx,dt,ust,pblh - LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA + logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA ! outputs - updraft properties - real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, & & edmf_qt,edmf_thl,edmf_ent,edmf_qc !add one local edmf variable: - real(kind_phys),DIMENSION(KTS:KTE) :: edmf_th + real(kind_phys),dimension(kts:kte) :: edmf_th ! output - INTEGER, INTENT(OUT) :: nup2,ktop - real(kind_phys), INTENT(OUT) :: maxmf - real(kind_phys), INTENT(OUT) :: ztop + integer, intent(out) :: ktop + real(kind_phys), intent(out) :: maxmf,ztop,maxwidth ! outputs - variables needed for solver - real(kind_phys),DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi + real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & &s_awqke,s_aw2 - real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: & + real(kind_phys),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=8, debug_mf=0 + real(kind_phys) :: nup2 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP) :: & + real(kind_phys),dimension(kts:kte+1,1:NUP) :: & &UPW,UPTHL,UPQT,UPQC,UPQV, & &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA ! entrainment variables - real(kind_phys),DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf - INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf + integer,dimension(kts:kte,1:NUP) :: ENTi ! internal variables - INTEGER :: K,I,k50 + integer :: K,I,k50 real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & - QNWFAn,QNIFAn,QNBCAn, & - Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + & QNWFAn,QNIFAn,QNBCAn, & + & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters - real(kind_phys), PARAMETER :: & + real(kind_phys), parameter :: & &Wa=2./3., & &Wb=0.002, & &Wc=1.5 ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. - real(kind_phys),PARAMETER :: & - & L0=100., & - & ENT0=0.1 - - ! Implement ideas from Neggers (2016, JAMES): - real(kind_phys), PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts - real(kind_phys), PARAMETER :: lmax = 1000.! diameter of largest plume - real(kind_phys), PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand - real(kind_phys), PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) - real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + real(kind_phys),parameter :: & + & L0=100., & + & ENT0=0.1 + + ! Parameters/variables for regulating plumes: + real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts + real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller) + real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger) + real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv) + real(kind_phys) :: minwidth ! actual width of smallest plume + real(kind_phys) :: dl ! variable increment of plume size + real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) + real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. - real(kind_phys):: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx + real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx ! chem/smoke - INTEGER, INTENT(IN) :: nchem - real(kind_phys),DIMENSION(:, :) :: chem1 - real(kind_phys),DIMENSION(kts:kte+1, nchem) :: s_awchem - real(kind_phys),DIMENSION(nchem) :: chemn - real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM - INTEGER :: ic - real(kind_phys),DIMENSION(KTS:KTE+1, nchem) :: edmf_chem - LOGICAL, INTENT(IN) :: mix_chem + integer, intent(in) :: nchem + real(kind_phys),dimension(:, :) :: chem1 + real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem + real(kind_phys),dimension(nchem) :: chemn + real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM + integer :: ic + real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem + logical, intent(in) :: mix_chem !JOE: add declaration of ERF real(kind_phys):: ERF - LOGICAL :: superadiabatic + logical :: superadiabatic ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm + real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm real(kind_phys):: 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(kind_phys), PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value + real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check - real(kind_phys),DIMENSION(KTS:KTE) :: exneri,dzi + real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl - real(kind_phys):: csigma,acfac,ac_wsp,ac_cld + real(kind_phys):: csigma,acfac,ac_wsp !plume overshoot - INTEGER :: overshoot + integer :: overshoot real(kind_phys):: bvf, Frz, dzp !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). !This limiter makes adjustments to the entire column. real(kind_phys):: adjustment, flx1 - real(kind_phys), PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact + real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that + ! 0.5 starts to have a noticeable impact ! over land (decrease maxMF by 10-20%), but no impact over water. !Subsidence - real(kind_phys),DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence + real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & envm_u,envm_v !environmental variables defined at middle of layer - real(kind_phys),DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface + real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & - qc_plume,exc_heat,exc_moist,tk_int - real(kind_phys), PARAMETER :: Cdet = 1./45. - real(kind_phys), PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers + qc_plume,exc_heat,exc_moist,tk_int,tvs + real(kind_phys), parameter :: Cdet = 1./45. + real(kind_phys), 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 !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme !is compensated by "gentle" environmental subsidence. - real(kind_phys), PARAMETER :: Csub=0.25 + real(kind_phys), parameter :: Csub=0.25 !Factor for the pressure gradient effects on momentum transport - real(kind_phys), PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere + real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa ! check the inputs @@ -5859,9 +5888,9 @@ SUBROUTINE DMP_mf( & UPQNWFA=0. UPQNIFA=0. UPQNBCA=0. - IF ( mix_chem ) THEN - UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 - ENDIF + if ( mix_chem ) then + UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0 + endif ENT=0.001 ! Initialize mean updraft properties @@ -5871,9 +5900,9 @@ SUBROUTINE DMP_mf( & edmf_thl=0. edmf_ent=0. edmf_qc =0. - IF ( mix_chem ) THEN + if ( mix_chem ) then edmf_chem(kts:kte+1,1:nchem) = 0.0 - ENDIF + endif ! Initialize the variables needed for implicit solver s_aw=0. @@ -5889,153 +5918,163 @@ SUBROUTINE DMP_mf( & s_awqnwfa=0. s_awqnifa=0. s_awqnbca=0. - IF ( mix_chem ) THEN + if ( mix_chem ) then s_awchem(kts:kte+1,1:nchem) = 0.0 - ENDIF + endif ! Initialize explicit tendencies for subsidence & detrainment sub_thl = 0. sub_sqv = 0. - sub_u = 0. - sub_v = 0. + sub_u = 0. + sub_v = 0. det_thl = 0. det_sqv = 0. det_sqc = 0. - det_u = 0. - det_v = 0. + det_u = 0. + det_v = 0. + nup2 = nup !start with nup, but set to zero if activation criteria fails ! Taper off MF scheme when significant resolved-scale motions ! are present This function needs to be asymetric... - k = 1 - maxw = 0.0 + maxw = 0.0 cloud_base = 9000.0 -! DO WHILE (ZW(k) < pblh + 500.) - DO k=1,kte-1 - IF(zw(k) > pblh + 500.) exit + do k=1,kte-1 + if (zw(k) > pblh + 500.) exit wpbl = w(k) - IF(w(k) < 0.)wpbl = 2.*w(k) - maxw = MAX(maxw,ABS(wpbl)) + if (w(k) < 0.)wpbl = 2.*w(k) + maxw = max(maxw,abs(wpbl)) !Find highest k-level below 50m AGL - IF(ZW(k)<=50.)k50=k + if (ZW(k)<=50.)k50=k !Search for cloud base - qc_sgs = MAX(qc(k), qc_bl1d(k)*cldfra_bl1d(k)) - IF(qc_sgs> 1E-5 .AND. cloud_base == 9000.0)THEN + qc_sgs = max(qc(k), qc_bl1d(k)) + if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then cloud_base = 0.5*(ZW(k)+ZW(k+1)) - ENDIF + endif + enddo - !k = k + 1 - ENDDO - !print*," maxw before manipulation=", maxw - maxw = MAX(0.,maxw - 1.0) ! do nothing for small w (< 1 m/s), but - Psig_w = MAX(0.0, 1.0 - maxw) ! linearly taper off for w > 1.0 m/s - Psig_w = MIN(Psig_w, Psig_shcu) - !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu + !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s + maxw = max(0.,maxw - 1.0) + Psig_w = max(0.0, 1.0 - maxw) + Psig_w = min(Psig_w, Psig_shcu) !Completely shut off MF scheme for strong resolved-scale vertical velocities. fltv2 = fltv - IF(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv + if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv ! If surface buoyancy is positive we do integration, otherwise no. ! Also, ensure that it is at least slightly superadiabatic up through 50 m superadiabatic = .false. - IF((landsea-1.5).GE.0)THEN + if ((landsea-1.5).ge.0) then hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m. - ELSE + else hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. - ENDIF - DO k=1,MAX(1,k50-1) !use "-1" because k50 used interface heights (zw). - IF (k == 1) then - IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN + endif + tvs = ts*(1.0+p608*qv(kts)) + do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw). + if (k == 1) then + if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then superadiabatic = .true. - ELSE + else superadiabatic = .false. exit - ENDIF - ELSE - IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN + endif + else + if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then superadiabatic = .true. - ELSE + else superadiabatic = .false. exit - ENDIF - ENDIF - ENDDO + endif + endif + enddo ! Determine the numer of updrafts/plumes in the grid column: ! Some of these criteria may be a little redundant but useful for bullet-proofing. - ! (1) largest plume = 1.0 * dx. - ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist. + ! (1) largest plume = 1.2 * dx. + ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist. ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes) ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only ! meant to "soften" the activation of the mass-flux scheme. ! Criteria (1) - NUP2 = max(1,min(NUP,INT(dx*dcut/dl))) + maxwidth = min(dx*dcut, lmax) !Criteria (2) - maxwidth = 1.1*PBLH + maxwidth = min(maxwidth, 1.1_kind_phys*PBLH) ! Criteria (3) - maxwidth = MIN(maxwidth,0.5*cloud_base) + if ((landsea-1.5) .lt. 0) then !land + maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base) + else !water + maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base) + endif ! Criteria (4) - wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01)) + wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys)) !Note: area fraction (acfac) is modified below ! Criteria (5) - only a function of flt (not fltv) if ((landsea-1.5).LT.0) then !land - !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys) else !water - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys) + endif + maxwidth = MIN(maxwidth, width_flx) + minwidth = lmin + !allow min plume size to increase in large flux conditions (eddy diffusivity should be + !large enough to handle the representation of small plumes). + if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys) + + if (maxwidth .le. minwidth) then ! deactivate MF component + nup2 = 0 + maxwidth = 0.0 endif - maxwidth = MIN(maxwidth,width_flx) - ! Convert maxwidth to number of plumes - NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) - !Initialize values for 2d output fields: - ktop = 0 - ztop = 0.0 - maxmf= 0.0 + ! Initialize values for 2d output fields: + ktop = 0 + ztop = 0.0 + maxmf= 0.0 - IF ( fltv2 > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then - !PRINT*," Conditions met to run mass-flux scheme",fltv2,pblh +!Begin plume processing if passes criteria +if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then ! Find coef C for number size density N cn = 0. - d=-1.9 !set d to value suggested by Neggers 2015 (JAMES). - !d=-1.9 + .2*tanh((fltv2 - 0.05)/0.15) - do I=1,NUP !NUP2 - IF(I > NUP2) exit - l = dl*I ! diameter of plume + d =-1.9 !set d to value suggested by Neggers 2015 (JAMES). + dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys) + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume enddo C = Atot/cn !Normalize C according to the defined total fraction (Atot) ! Make updraft area (UPA) a function of the buoyancy flux if ((landsea-1.5).LT.0) then !land - !acfac = .5*tanh((fltv2 - 0.03)/0.09) + .5 - !acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5 acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 else !water acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 endif !add a windspeed-dependent adjustment to acfac that tapers off - !the mass-flux scheme linearly above sfc wind speeds of 20 m/s: - ac_wsp = 1.0 - min(max(wspd_pbl - 20.0, 0.0), 10.0)/10.0 - !reduce area fraction beneath cloud bases < 1200 m AGL - ac_cld = min(cloud_base/1200., 1.0) - acfac = acfac * min(ac_wsp, ac_cld) + !the mass-flux scheme linearly above sfc wind speeds of 10 m/s. + !Note: this effect may be better represented by an increase in + !entrainment rate for high wind consitions (more ambient turbulence). + if (wspd_pbl .le. 10.) then + ac_wsp = 1.0 + else + ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0) + endif + acfac = acfac * ac_wsp ! Find the portion of the total fraction (Atot) of each plume size: An2 = 0. - do I=1,NUP !NUP2 - IF(I > NUP2) exit - l = dl*I ! diameter of plume + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) N = C*l**d ! number density of plume n - UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n + UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n - UPA(1,I) = UPA(1,I)*acfac - An2 = An2 + UPA(1,I) ! total fractional area of all plumes + UPA(1,i) = UPA(1,i)*acfac + An2 = An2 + UPA(1,i) ! total fractional area of all plumes !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 end do @@ -6048,23 +6087,25 @@ SUBROUTINE DMP_mf( & qstar=max(flq,1.0E-5)/wstar thstar=flt/wstar - IF((landsea-1.5).GE.0)THEN + if ((landsea-1.5) .ge. 0) then csigma = 1.34 ! WATER - ELSE + else csigma = 1.34 ! LAND - ENDIF + endif if (env_subs) then exc_fac = 0.0 else if ((landsea-1.5).GE.0) then !water: increase factor to compensate for decreased pwmin/pwmax - exc_fac = 0.58*4.0*min(cloud_base/1000., 1.0) + exc_fac = 0.58*4.0 else !land: no need to increase factor - already sufficiently large superadiabatic layers exc_fac = 0.58 endif endif + !decrease excess for large wind speeds + exc_fac = exc_fac * ac_wsp !Note: sigmaW is typically about 0.5*wstar sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh) @@ -6077,14 +6118,11 @@ SUBROUTINE DMP_mf( & wmax=MIN(sigmaW*pwmax,0.5) !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + do i=1,NUP wlv=wmin+(wmax-wmin)/NUP2*(i-1) !SURFACE UPDRAFT VERTICAL VELOCITY UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin) - !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt - UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQC(1,I)=0.0 @@ -6093,21 +6131,11 @@ SUBROUTINE DMP_mf( & 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_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_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 @@ -6117,36 +6145,36 @@ SUBROUTINE DMP_mf( & UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - ENDDO + enddo - IF ( mix_chem ) THEN - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + if ( mix_chem ) then + do i=1,NUP do ic = 1,nchem - UPCHEM(1,I,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) enddo - ENDDO - ENDIF + enddo + endif !Initialize environmental variables which can be modified by detrainment - DO k=kts,kte - envm_thl(k)=THL(k) - envm_sqv(k)=QV(k) - envm_sqc(k)=QC(k) - envm_u(k)=U(k) - envm_v(k)=V(k) - ENDDO + envm_thl(kts:kte)=THL(kts:kte) + envm_sqv(kts:kte)=QV(kts:kte) + envm_sqc(kts:kte)=QC(kts:kte) + envm_u(kts:kte)=U(kts:kte) + envm_v(kts:kte)=V(kts:kte) + do k=kts,kte-1 + rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) + enddo + rhoz(kte) = rho(kte) !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) ! do integration updraft - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + do i=1,NUP QCn = 0. overshoot = 0 - l = dl*I ! diameter of plume - DO k=KTS+1,KTE-1 + l = minwidth + dl*real(i-1) ! diameter of plume + do k=kts+1,kte-1 !Entrainment from Tian and Kuang (2016) !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh @@ -6161,7 +6189,7 @@ SUBROUTINE DMP_mf( & ENT(k,i) = max(ENT(k,i),0.0003) !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang - !JOE - increase entrainment for plumes extending very high. + !increase entrainment for plumes extending very high. IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6 ENDIF @@ -6339,6 +6367,7 @@ SUBROUTINE DMP_mf( & exit !exit k-loop END IF ENDDO + IF (debug_mf == 1) THEN IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN @@ -6358,30 +6387,26 @@ SUBROUTINE DMP_mf( & ENDIF ENDIF ENDDO - ELSE +ELSE !At least one of the conditions was not met for activating the MF scheme. NUP2=0. - END IF !end criteria for mass-flux scheme +END IF !end criteria check for mass-flux scheme - ktop=MIN(ktop,KTE-1) ! Just to be safe... - IF (ktop == 0) THEN - ztop = 0.0 - ELSE - ztop=zw(ktop) - ENDIF - - IF(nup2 > 0) THEN +ktop=MIN(ktop,KTE-1) +IF (ktop == 0) THEN + ztop = 0.0 +ELSE + ztop=zw(ktop) +ENDIF - !Calculate the fluxes for each variable - !All s_aw* variable are == 0 at k=1 - DO i=1,NUP !NUP2 - IF(I > NUP2) exit +IF (nup2 > 0) THEN + !Calculate the fluxes for each variable + !All s_aw* variable are == 0 at k=1 + DO i=1,NUP DO k=KTS,KTE-1 - IF(k > ktop) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - s_aw(k+1) = s_aw(k+1) + rho_int*UPA(K,i)*UPW(K,i)*Psig_w - 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 + s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w + s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w + s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*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 preserved but !negative qc fluxes in unsaturated layers is reduced. @@ -6390,72 +6415,76 @@ SUBROUTINE DMP_mf( & ! else ! qc_plume = 0.0 ! endif - s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w - IF (momentum_opt > 0) THEN - s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w - s_awv(k+1) = s_awv(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w - ENDIF - IF (tke_opt > 0) THEN - s_awqke(k+1)= s_awqke(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w - ENDIF + s_awqc(k+1) = s_awqc(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) ENDDO - ENDDO - - IF ( mix_chem ) THEN - DO k=KTS,KTE - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO i=1,NUP !NUP2 - IF(I > NUP2) exit - do ic = 1,nchem - s_awchem(k+1,ic) = s_awchem(k+1,ic) + rho_int*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w - enddo - ENDDO - ENDDO - ENDIF - - IF (scalar_opt > 0) THEN - DO k=KTS,KTE - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO I=1,NUP !NUP2 - IF (I > NUP2) exit - s_awqnc(k+1)= s_awqnc(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w - s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w - s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w - s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w - s_awqnbca(k+1)= s_awqnbca(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w - ENDDO - ENDDO - ENDIF + ENDDO + !momentum + if (momentum_opt > 0) then + do i=1,nup + do k=kts,kte-1 + s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w + s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w + enddo + enddo + endif + !tke + if (tke_opt > 0) then + do i=1,nup + do k=kts,kte-1 + s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w + enddo + enddo + endif + !chem + if ( mix_chem ) then + do k=kts,kte + do i=1,nup + do ic = 1,nchem + s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w + enddo + enddo + enddo + endif + + if (scalar_opt > 0) then + do k=kts,kte + do I=1,nup + s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w + s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w + s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w + s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w + enddo + enddo + endif - !Flux limiter: Check ratio of heat flux at top of first model layer - !and at the surface. Make sure estimated flux out of the top of the - !layer is < fluxportion*surface_heat_flux - IF (s_aw(kts+1) /= 0.) THEN + !Flux limiter: Check ratio of heat flux at top of first model layer + !and at the surface. Make sure estimated flux out of the top of the + !layer is < fluxportion*surface_heat_flux + IF (s_aw(kts+1) /= 0.) THEN dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5) - ELSE + ELSE flx1 = 0.0 !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,& ! " superadiabatic=",superadiabatic," KTOP=",KTOP - ENDIF - adjustment=1.0 - !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 - !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) - IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN + ENDIF + adjustment=1.0 + !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 + !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) + IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN adjustment= fluxportion*flt/dz(kts)/flx1 - s_aw = s_aw*adjustment - s_awthl= s_awthl*adjustment - s_awqt = s_awqt*adjustment - s_awqc = s_awqc*adjustment - s_awqv = s_awqv*adjustment - s_awqnc= s_awqnc*adjustment - s_awqni= s_awqni*adjustment - s_awqnwfa= s_awqnwfa*adjustment - s_awqnifa= s_awqnifa*adjustment - s_awqnbca= s_awqnbca*adjustment + s_aw = s_aw*adjustment + s_awthl = s_awthl*adjustment + s_awqt = s_awqt*adjustment + s_awqc = s_awqc*adjustment + s_awqv = s_awqv*adjustment + s_awqnc = s_awqnc*adjustment + s_awqni = s_awqni*adjustment + s_awqnwfa = s_awqnwfa*adjustment + s_awqnifa = s_awqnifa*adjustment + s_awqnbca = s_awqnbca*adjustment IF (momentum_opt > 0) THEN s_awu = s_awu*adjustment s_awv = s_awv*adjustment @@ -6467,62 +6496,57 @@ SUBROUTINE DMP_mf( & s_awchem = s_awchem*adjustment ENDIF UPA = UPA*adjustment - ENDIF - !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt - - !Calculate mean updraft properties for output: - !all edmf_* variables at k=1 correspond to the interface at top of first model layer - DO k=KTS,KTE-1 - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO I=1,NUP !NUP2 - IF(I > NUP2) exit - edmf_a(K) =edmf_a(K) +UPA(K,i) - edmf_w(K) =edmf_w(K) +rho_int*UPA(K,i)*UPW(K,i) - edmf_qt(K) =edmf_qt(K) +rho_int*UPA(K,i)*UPQT(K,i) - edmf_thl(K)=edmf_thl(K)+rho_int*UPA(K,i)*UPTHL(K,i) - edmf_ent(K)=edmf_ent(K)+rho_int*UPA(K,i)*ENT(K,i) - edmf_qc(K) =edmf_qc(K) +rho_int*UPA(K,i)*UPQC(K,i) - ENDDO - + ENDIF + !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt + + !Calculate mean updraft properties for output: + !all edmf_* variables at k=1 correspond to the interface at top of first model layer + do k=kts,kte-1 + do I=1,nup + edmf_a(K) =edmf_a(K) +UPA(K,i) + edmf_w(K) =edmf_w(K) +rhoz(k)*UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +rhoz(k)*UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+rhoz(k)*UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+rhoz(k)*UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +rhoz(k)*UPA(K,i)*UPQC(K,i) + enddo + enddo + do k=kts,kte-1 !Note that only edmf_a is multiplied by Psig_w. This takes care of the !scale-awareness of the subsidence below: - IF (edmf_a(k)>0.) THEN - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) - edmf_a(k)=edmf_a(k)*Psig_w - - !FIND MAXIMUM MASS-FLUX IN THE COLUMN: - IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) - ENDIF - ENDDO ! end k - - !smoke/chem - IF ( mix_chem ) THEN - DO k=kts,kte-1 - IF(k > KTOP) exit - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + if (edmf_a(k)>0.) then + edmf_w(k)=edmf_w(k)/edmf_a(k) + edmf_qt(k)=edmf_qt(k)/edmf_a(k) + edmf_thl(k)=edmf_thl(k)/edmf_a(k) + edmf_ent(k)=edmf_ent(k)/edmf_a(k) + edmf_qc(k)=edmf_qc(k)/edmf_a(k) + edmf_a(k)=edmf_a(k)*Psig_w + !FIND MAXIMUM MASS-FLUX IN THE COLUMN: + if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) + endif + enddo ! end k + + !smoke/chem + if ( mix_chem ) then + do k=kts,kte-1 + do I=1,nup do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic) + edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic) enddo - ENDDO - - IF (edmf_a(k)>0.) THEN + enddo + enddo + do k=kts,kte-1 + if (edmf_a(k)>0.) then do ic = 1,nchem edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) enddo - ENDIF - ENDDO ! end k - ENDIF + endif + enddo ! end k + endif - !Calculate the effects environmental subsidence. - !All envi_*variables are valid at the interfaces, like the edmf_* variables - IF (env_subs) THEN + !Calculate the effects environmental subsidence. + !All envi_*variables are valid at the interfaces, like the edmf_* variables + IF (env_subs) THEN DO k=kts+1,kte-1 !First, smooth the profiles of w & a, since sharp vertical gradients !in plume variables are not likely extended to env variables @@ -6557,18 +6581,16 @@ SUBROUTINE DMP_mf( & !calculate tendencies from subsidence and detrainment valid at the middle of !each model layer. The lowest model layer uses an assumes w=0 at the surface. dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) - rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rho_int + (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k) sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rho_int + (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k) DO k=kts+1,kte-1 dzi(k) = 0.5*(dz(k)+dz(k+1)) - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rho_int + (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k) sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rho_int + (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k) ENDDO DO k=KTS,KTE-1 @@ -6578,17 +6600,15 @@ SUBROUTINE DMP_mf( & ENDDO IF (momentum_opt > 0) THEN - rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rho_int + (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k) sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rho_int + (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k) DO k=kts+1,kte-1 - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rho_int + (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k) sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rho_int + (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k) ENDDO DO k=KTS,KTE-1 @@ -6596,23 +6616,23 @@ SUBROUTINE DMP_mf( & det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w ENDDO ENDIF - ENDIF !end subsidence/env detranment + ENDIF !end subsidence/env detranment - !First, compute exner, plume theta, and dz centered at interface - !Here, k=1 is the top of the first model layer. These values do not - !need to be defined at k=kte (unused level). - DO K=KTS,KTE-1 - exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + !First, compute exner, plume theta, and dz centered at interface + !Here, k=1 is the top of the first model layer. These values do not + !need to be defined at k=kte (unused level). + DO K=KTS,KTE-1 + exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k)) edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) - dzi(k) = 0.5*(DZ(k)+DZ(k+1)) - ENDDO + dzi(k) = 0.5*(dz(k)+dz(k+1)) + ENDDO !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in ! 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 .and. (cldfra_bl1d(k) < cf_thresh))THEN + do k=kts+1,kte-2 + if (k > KTOP) exit + if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))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)) @@ -6686,8 +6706,8 @@ SUBROUTINE DMP_mf( & !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) !Original CB mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) - mf_cf = max(mf_cf, 1.75 * Aup) - mf_cf = min(mf_cf, 5.0 * Aup) + mf_cf = max(mf_cf, 1.8 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) endif !IF ( debug_code ) THEN @@ -6705,10 +6725,7 @@ SUBROUTINE DMP_mf( & 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 + qc_bl1d(k) = 1.18 * (QCp * Aup) endif cldfra_bl1d(k) = mf_cf Ac_mf = mf_cf @@ -6718,9 +6735,6 @@ SUBROUTINE DMP_mf( & 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 @@ -6752,13 +6766,13 @@ SUBROUTINE DMP_mf( & endif !check for (qc in plume) .and. (cldfra_bl < threshold) enddo !k-loop - ENDIF !end nup2 > 0 +ENDIF !end nup2 > 0 - !modify output (negative: dry plume, positive: moist plume) - if (ktop > 0) then - maxqc = maxval(edmf_qc(1:ktop)) - if ( maxqc < 1.E-8) maxmf = -1.0*maxmf - endif +!modify output (negative: dry plume, positive: moist plume) +if (ktop > 0) then + maxqc = maxval(edmf_qc(1:ktop)) + if ( maxqc < 1.E-8) maxmf = -1.0*maxmf +endif ! ! debugging @@ -6927,62 +6941,68 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & &qc_bl1d,cldfra_bl1d, & &rthraten ) - INTEGER, INTENT(IN) :: KTS,KTE,KPBL - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& - THV,P,rho,exner,dz - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten + integer, intent(in) :: KTS,KTE,KPBL + real(kind_phys), dimension(kts:kte), intent(in) :: & + U,V,TH,THL,TK,QT,QV,QC,THV,P,rho,exner,dz + real(kind_phys), dimension(kts:kte), intent(in) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) - real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - real(kind_phys), INTENT(IN) :: WTHL,WQT - real(kind_phys), INTENT(IN) :: dt,ust,pblh + real(kind_phys), dimension(kts:kte+1), intent(in) :: ZW + real(kind_phys), intent(in) :: WTHL,WQT + real(kind_phys), intent(in) :: dt,ust,pblh ! outputs - downdraft properties - real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & - & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd + real(kind_phys), dimension(kts:kte), intent(out) :: & + edmf_a_dd,edmf_w_dd, & + edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii) - real(kind_phys),DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & - sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 + real(kind_phys), dimension(kts:kte+1) :: & + sd_aw, sd_awthl, sd_awqt, sd_awu, & + sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 - real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d + real(kind_phys), dimension(kts:kte), intent(in) :: & + qc_bl1d, cldfra_bl1d - INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5 + integer, parameter:: ndown = 5 ! draw downdraft starting height randomly between cloud base and cloud top - INTEGER, DIMENSION(1:NDOWN) :: DD_initK - real(kind_phys) , DIMENSION(1:NDOWN) :: randNum + integer, dimension(1:NDOWN) :: DD_initK + real(kind_phys), dimension(1:NDOWN) :: randNum ! downdraft properties - real(kind_phys),DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& - DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV + real(kind_phys), dimension(kts:kte+1,1:NDOWN) :: & + DOWNW,DOWNTHL,DOWNQT,DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV ! entrainment variables - Real(Kind_phys),DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf - INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi + real(kind_phys), dimension(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf + integer, dimension(KTS+1:KTE+1,1:NDOWN) :: ENTi ! internal variables - INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase - real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & - pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw - real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & - EntEXP,EntW, Beta_dm, EntExp_M, rho_int - real(kind_phys):: jump_thetav, jump_qt, jump_thetal, & + integer :: K,I,ki, kminrad, qlTop, p700_ind, qlBase + real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT, & + sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn, & + THVk,Pk,EntEXP,EntW,beta_dm,EntExp_M,rho_int + real(kind_phys):: jump_thetav, jump_qt, jump_thetal, & refTHL, refTHV, refQT ! DD specific internal variables real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - - real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& + real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt, & Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters - real(kind_phys),PARAMETER :: & - &Wa=1., & - &Wb=1.5,& - &Z00=100.,& - &BCOEFF=0.2 + real(kind_phys),parameter :: & + &Wa=1., Wb=1.5, Z00=100., BCOEFF=0.2 ! entrainment parameters - real(kind_phys),PARAMETER :: & - & L0=80,& - & ENT0=0.2 - + real(kind_phys),parameter :: & + &L0=80, ENT0=0.2 + !downdraft properties + real(kind_phys):: & + & dp, & !diameter of plume + & dl, & !diameter increment + & Adn !total area of downdrafts + !additional printouts for debugging + integer, parameter :: debug_mf=0 + + dl = (1000.-500.)/real(ndown) pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma pwmax=-1. @@ -7052,6 +7072,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & if ( radflux < 0.0 ) F0 = abs(radflux) + F0 enddo F0 = max(F0, 1.0) + + !Allow the total fractional area of the downdrafts to be proportional + !to the radiative forcing: + !for 50 W/m2, Adn = 0.10 + !for 100 W/m2, Adn = 0.15 + !for 150 W/m2, Adn = 0.20 + Adn = min( 0.05 + F0*0.001, 0.3) + !found Sc cloud and cloud not at surface, trigger downdraft if (cloudflg) then @@ -7066,14 +7094,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & ! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi) - ! entrainent: Ent=Ent0/dz*P(dz/L0) - do i=1,NDOWN - do k=kts+1,kte -! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) - ENT(k,i) = 0.002 - ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - enddo - enddo +! ! entrainent: Ent=Ent0/dz*P(dz/L0) +! do i=1,NDOWN +! do k=kts+1,kte +!! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) +! ENT(k,i) = 0.002 +! ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) +! enddo +! enddo !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!! p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000 @@ -7116,8 +7144,10 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & !DOWNW(ki,I)=0.5*(wlv+wtv) DOWNW(ki,I)=wlv + !multiply downa by cloud fraction, so it's impact will diminish if + !clouds are mixed away over the course of the longer radiation time step !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW)) - DOWNA(ki,I)=.1/real(NDOWN) + DOWNA(ki,I)=Adn/real(NDOWN) DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) @@ -7144,16 +7174,21 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & enddo - !print*, " Begin integration of downdrafts:" DO I=1,NDOWN + dp = 500. + dl*real(I) ! diameter of plume (meters) !print *, "Plume # =", I,"=======================" DO k=DD_initK(I)-1,KTS+1,-1 + + !Entrainment from Tian and Kuang (2016), with constraints + wmin = 0.3 + dp*0.0005 + ENT(k,i) = 0.33/(MIN(MAX(-1.0*DOWNW(k+1,I),wmin),0.9)*dp) + !starting at the first interface level below cloud top !EntExp=exp(-ENT(K,I)*dz(k)) !EntExp_M=exp(-ENT(K,I)/3.*dz(k)) - EntExp =ENT(K,I)*dz(k) - EntExp_M=ENT(K,I)*0.333*dz(k) + EntExp =ENT(K,I)*dz(k) !for all scalars + EntExp_M=ENT(K,I)*0.333*dz(k) !test for momentum QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp @@ -7187,11 +7222,11 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & BCOEFF*B/mindownw)*MIN(dz(k), 250.) !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. - !Add max increase of 2.0 m/s for coarse vertical resolution. - IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0))THEN - Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0) + !Add max acceleration of -2.0 m/s for coarse vertical resolution. + IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN + Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0) ENDIF - !Add symmetrical max decrease in w + !Add symmetrical max decrease in velocity (less negative) IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0) ENDIF @@ -7237,7 +7272,6 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & ! Even though downdraft starts at different height, average all up to qlTop DO k=qlTop,KTS,-1 DO I=1,NDOWN - IF (I > NDOWN) exit edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) @@ -7287,8 +7321,8 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - real(kind_phys), INTENT(IN) :: dx,pbl1 - real(kind_phys), INTENT(OUT) :: Psig_bl,Psig_shcu + real(kind_phys), intent(in) :: dx,pbl1 + real(kind_phys), intent(out) :: Psig_bl,Psig_shcu real(kind_phys) :: dxdh Psig_bl=1.0 @@ -7361,28 +7395,28 @@ FUNCTION esat_blend(t) IMPLICIT NONE - real(kind_phys), INTENT(IN):: t + real(kind_phys), intent(in):: t real(kind_phys):: esat_blend,XC,ESL,ESI,chi !liquid - real(kind_phys), PARAMETER:: J0= .611583699E03 - real(kind_phys), PARAMETER:: J1= .444606896E02 - real(kind_phys), PARAMETER:: J2= .143177157E01 - real(kind_phys), PARAMETER:: J3= .264224321E-1 - real(kind_phys), PARAMETER:: J4= .299291081E-3 - real(kind_phys), PARAMETER:: J5= .203154182E-5 - real(kind_phys), PARAMETER:: J6= .702620698E-8 - real(kind_phys), PARAMETER:: J7= .379534310E-11 - real(kind_phys), PARAMETER:: J8=-.321582393E-13 + real(kind_phys), parameter:: J0= .611583699E03 + real(kind_phys), parameter:: J1= .444606896E02 + real(kind_phys), parameter:: J2= .143177157E01 + real(kind_phys), parameter:: J3= .264224321E-1 + real(kind_phys), parameter:: J4= .299291081E-3 + real(kind_phys), parameter:: J5= .203154182E-5 + real(kind_phys), parameter:: J6= .702620698E-8 + real(kind_phys), parameter:: J7= .379534310E-11 + real(kind_phys), parameter:: J8=-.321582393E-13 !ice - real(kind_phys), PARAMETER:: K0= .609868993E03 - real(kind_phys), PARAMETER:: K1= .499320233E02 - real(kind_phys), PARAMETER:: K2= .184672631E01 - real(kind_phys), PARAMETER:: K3= .402737184E-1 - real(kind_phys), PARAMETER:: K4= .565392987E-3 - real(kind_phys), PARAMETER:: K5= .521693933E-5 - real(kind_phys), PARAMETER:: K6= .307839583E-7 - real(kind_phys), PARAMETER:: K7= .105785160E-9 - real(kind_phys), PARAMETER:: K8= .161444444E-12 + real(kind_phys), parameter:: K0= .609868993E03 + real(kind_phys), parameter:: K1= .499320233E02 + real(kind_phys), parameter:: K2= .184672631E01 + real(kind_phys), parameter:: K3= .402737184E-1 + real(kind_phys), parameter:: K4= .565392987E-3 + real(kind_phys), parameter:: K5= .521693933E-5 + real(kind_phys), parameter:: K6= .307839583E-7 + real(kind_phys), parameter:: K7= .105785160E-9 + real(kind_phys), parameter:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 @@ -7412,28 +7446,28 @@ FUNCTION qsat_blend(t, P) IMPLICIT NONE - real(kind_phys), INTENT(IN):: t, P + real(kind_phys), intent(in):: t, P real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi !liquid - real(kind_phys), PARAMETER:: J0= .611583699E03 - real(kind_phys), PARAMETER:: J1= .444606896E02 - real(kind_phys), PARAMETER:: J2= .143177157E01 - real(kind_phys), PARAMETER:: J3= .264224321E-1 - real(kind_phys), PARAMETER:: J4= .299291081E-3 - real(kind_phys), PARAMETER:: J5= .203154182E-5 - real(kind_phys), PARAMETER:: J6= .702620698E-8 - real(kind_phys), PARAMETER:: J7= .379534310E-11 - real(kind_phys), PARAMETER:: J8=-.321582393E-13 + real(kind_phys), parameter:: J0= .611583699E03 + real(kind_phys), parameter:: J1= .444606896E02 + real(kind_phys), parameter:: J2= .143177157E01 + real(kind_phys), parameter:: J3= .264224321E-1 + real(kind_phys), parameter:: J4= .299291081E-3 + real(kind_phys), parameter:: J5= .203154182E-5 + real(kind_phys), parameter:: J6= .702620698E-8 + real(kind_phys), parameter:: J7= .379534310E-11 + real(kind_phys), parameter:: J8=-.321582393E-13 !ice - real(kind_phys), PARAMETER:: K0= .609868993E03 - real(kind_phys), PARAMETER:: K1= .499320233E02 - real(kind_phys), PARAMETER:: K2= .184672631E01 - real(kind_phys), PARAMETER:: K3= .402737184E-1 - real(kind_phys), PARAMETER:: K4= .565392987E-3 - real(kind_phys), PARAMETER:: K5= .521693933E-5 - real(kind_phys), PARAMETER:: K6= .307839583E-7 - real(kind_phys), PARAMETER:: K7= .105785160E-9 - real(kind_phys), PARAMETER:: K8= .161444444E-12 + real(kind_phys), parameter:: K0= .609868993E03 + real(kind_phys), parameter:: K1= .499320233E02 + real(kind_phys), parameter:: K2= .184672631E01 + real(kind_phys), parameter:: K3= .402737184E-1 + real(kind_phys), parameter:: K4= .565392987E-3 + real(kind_phys), parameter:: K5= .521693933E-5 + real(kind_phys), parameter:: K6= .307839583E-7 + real(kind_phys), parameter:: K7= .105785160E-9 + real(kind_phys), parameter:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) @@ -7470,7 +7504,7 @@ FUNCTION xl_blend(t) IMPLICIT NONE - real(kind_phys), INTENT(IN):: t + real(kind_phys), intent(in):: t real(kind_phys):: xl_blend,xlvt,xlst,chi !note: t0c = 273.15, tice is set in mynn_common @@ -7499,11 +7533,11 @@ FUNCTION phim(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - real(kind_phys), INTENT(IN):: zet + real(kind_phys), intent(in):: zet real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. real(kind_phys):: phi_m,phim if ( zet >= 0.0 ) then @@ -7551,11 +7585,11 @@ FUNCTION phih(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - real(kind_phys), INTENT(IN):: zet + real(kind_phys), intent(in):: zet real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. real(kind_phys):: phh,phih if ( zet >= 0.0 ) then diff --git a/physics/mynnedmf_wrapper.F90 b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.F90 similarity index 97% rename from physics/mynnedmf_wrapper.F90 rename to physics/PBL/MYNN_EDMF/mynnedmf_wrapper.F90 index 3c7de235f..487753027 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.F90 @@ -131,7 +131,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & edmf_a,edmf_w,edmf_qt, & & edmf_thl,edmf_ent,edmf_qc, & & sub_thl,sub_sqv,det_thl,det_sqv,& - & nupdraft,maxMF,ktop_plume, & + & maxwidth,maxMF,ztop_plume, & + & ktop_plume, & & dudt, dvdt, dtdt, & & dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw & dqdt_ice, dqdt_snow, & ! <=== ntiw, ntsw @@ -310,9 +311,9 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind_phys), dimension(:), intent(out) :: & & ch,dtsfc1,dqsfc1,dusfc1,dvsfc1, & & dtsfci_diag,dqsfci_diag,dusfci_diag,dvsfci_diag, & - & maxMF + & maxMF,maxwidth,ztop_plume integer, dimension(:), intent(inout) :: & - & kpbl,nupdraft,ktop_plume + & kpbl,ktop_plume real(kind_phys), dimension(:), intent(inout) :: & & dusfc_cpl,dvsfc_cpl,dtsfc_cpl,dqsfc_cpl @@ -325,6 +326,7 @@ SUBROUTINE mynnedmf_wrapper_run( & integer :: idtend real(kind_phys), dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 real(kind_phys), allocatable :: save_qke_adv(:,:) + real(kind_phys), dimension(levs) :: kzero ! Initialize CCPP error handling variables errmsg = '' @@ -355,6 +357,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !print*,"in MYNN, initflag=",initflag endif + kzero = zero !generic zero array !initialize arrays for test EMIS_ANT_NO = 0. @@ -391,7 +394,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. - FLAG_QS = .false. !.true. + FLAG_QS = .true. FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. FLAG_QNBCA= .false. @@ -400,7 +403,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0.0 !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) @@ -418,7 +421,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .false. + FLAG_QS = .true. !pipe it in, but do not mix FLAG_QNC= .true. FLAG_QNWFA= .true. FLAG_QNIFA= .true. @@ -428,7 +431,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -441,7 +444,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .false. + FLAG_QS = .true. FLAG_QNC= .true. FLAG_QNWFA= .false. FLAG_QNIFA= .false. @@ -451,7 +454,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -464,7 +467,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .false. + FLAG_QS = .true. FLAG_QNC= .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. @@ -474,7 +477,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. !qgrs_snow(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = 0. qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -565,7 +568,7 @@ SUBROUTINE mynnedmf_wrapper_run( & call moisture_check2(levs, delt, & delp(i,:), exner(i,:), & sqv(i,:), sqc(i,:), & - sqi(i,:), sqs(i,:), & + sqi(i,:), kzero(:), & t3d(i,:) ) enddo @@ -748,7 +751,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,& !output & sub_thl3D=sub_thl,sub_sqv3D=sub_sqv, & & det_thl3D=det_thl,det_sqv3D=det_sqv, & - & nupdraft=nupdraft,maxMF=maxMF, & !output + & maxwidth=maxwidth,maxMF=maxMF,ztop_plume=ztop_plume,& !output & ktop_plume=ktop_plume, & !output & spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input & RTHRATEN=htrlw, & !input @@ -834,7 +837,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 dqdt_water_aer_num_conc(i,k) = RQNWFABLTEN(i,k) dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k) @@ -869,7 +872,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) enddo enddo if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then @@ -887,7 +890,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -917,7 +920,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - !dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) IF ( nssl_ccn_on ) THEN ! dqdt_cccn(i,k) = RQNWFABLTEN(i,k) ENDIF @@ -1005,8 +1008,8 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"dudt:",dudt(1,1),dudt(1,2),dudt(1,levs) print*,"dvdt:",dvdt(1,1),dvdt(1,2),dvdt(1,levs) print*,"dqdt:",dqdt_water_vapor(1,1),dqdt_water_vapor(1,2),dqdt_water_vapor(1,levs) - print*,"ktop_plume:",ktop_plume(1)," maxmf:",maxmf(1) - print*,"nup:",nupdraft(1) + print*,"ztop_plume:",ztop_plume(1)," maxmf:",maxmf(1) + print*,"maxwidth:",maxwidth(1) print* endif diff --git a/physics/mynnedmf_wrapper.meta b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.meta similarity index 98% rename from physics/mynnedmf_wrapper.meta rename to physics/PBL/MYNN_EDMF/mynnedmf_wrapper.meta index ec4706aba..00589dfe5 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/PBL/MYNN_EDMF/mynnedmf_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnedmf_wrapper type = scheme - dependencies = machine.F,module_bl_mynn.F90,physcons.F90,bl_mynn_common.f90 + dependencies = ../../hooks/machine.F,module_bl_mynn.F90,bl_mynn_common.f90 ######################################################################## [ccpp-arg-table] @@ -964,13 +964,14 @@ type = real kind = kind_phys intent = inout -[nupdraft] - standard_name = number_of_plumes - long_name = number of plumes per grid column - units = count +[maxwidth] + standard_name = maximum_width_of_plumes + long_name = maximum width of plumes per grid column + units = m dimensions = (horizontal_loop_extent) - type = integer - intent = inout + type = real + kind = kind_phys + intent = out [maxMF] standard_name = maximum_mass_flux long_name = maximum mass flux within a column @@ -979,6 +980,14 @@ type = real kind = kind_phys intent = out +[ztop_plume] + standard_name = height_of_tallest_plume_in_a_column + long_name = height of tallest plume in a column + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [ktop_plume] standard_name = k_level_of_highest_plume long_name = k-level of highest plume diff --git a/physics/mfscu.f b/physics/PBL/SATMEDMF/mfscu.f similarity index 100% rename from physics/mfscu.f rename to physics/PBL/SATMEDMF/mfscu.f diff --git a/physics/mfscuq.f b/physics/PBL/SATMEDMF/mfscuq.f similarity index 100% rename from physics/mfscuq.f rename to physics/PBL/SATMEDMF/mfscuq.f diff --git a/physics/satmedmfvdif.F b/physics/PBL/SATMEDMF/satmedmfvdif.F similarity index 100% rename from physics/satmedmfvdif.F rename to physics/PBL/SATMEDMF/satmedmfvdif.F diff --git a/physics/satmedmfvdif.meta b/physics/PBL/SATMEDMF/satmedmfvdif.meta similarity index 99% rename from physics/satmedmfvdif.meta rename to physics/PBL/SATMEDMF/satmedmfvdif.meta index 3609ed50f..b94e74d6c 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/PBL/SATMEDMF/satmedmfvdif.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdif type = scheme - dependencies = funcphys.f90,machine.F,mfpblt.f,mfscu.f,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpblt.f,mfscu.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/satmedmfvdifq.F b/physics/PBL/SATMEDMF/satmedmfvdifq.F similarity index 99% rename from physics/satmedmfvdifq.F rename to physics/PBL/SATMEDMF/satmedmfvdifq.F index 73fc4aff8..7b54b6d12 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.F @@ -271,7 +271,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(elmfac=1.0,elefac=1.0,cql=100.) parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=1000.) parameter(qlcr=3.5e-5,zstblmax=2500.) - parameter(xkinv1=0.15,xkinv2=0.3) + parameter(xkinv1=0.4,xkinv2=0.3) parameter(h1=0.33333333,hcrinv=250.) parameter(vegflo=0.1,vegfup=1.0,z0lo=0.1,z0up=1.0) parameter(vc0=1.0,zc0=1.0) diff --git a/physics/satmedmfvdifq.meta b/physics/PBL/SATMEDMF/satmedmfvdifq.meta similarity index 99% rename from physics/satmedmfvdifq.meta rename to physics/PBL/SATMEDMF/satmedmfvdifq.meta index b6680dccb..ff718f138 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdifq type = scheme - dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpbltq.f,mfscuq.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/moninshoc.f b/physics/PBL/SHOC/moninshoc.f similarity index 100% rename from physics/moninshoc.f rename to physics/PBL/SHOC/moninshoc.f diff --git a/physics/moninshoc.meta b/physics/PBL/SHOC/moninshoc.meta similarity index 99% rename from physics/moninshoc.meta rename to physics/PBL/SHOC/moninshoc.meta index dca5736f5..474689ea0 100644 --- a/physics/moninshoc.meta +++ b/physics/PBL/SHOC/moninshoc.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = moninshoc type = scheme - dependencies = funcphys.f90,machine.F,mfpbl.f,tridi.f + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpbl.f,../tridi.f ######################################################################## [ccpp-arg-table] diff --git a/physics/shoc.F90 b/physics/PBL/SHOC/shoc.F90 similarity index 100% rename from physics/shoc.F90 rename to physics/PBL/SHOC/shoc.F90 diff --git a/physics/shoc.meta b/physics/PBL/SHOC/shoc.meta similarity index 99% rename from physics/shoc.meta rename to physics/PBL/SHOC/shoc.meta index 984c6aec5..a1550ce11 100644 --- a/physics/shoc.meta +++ b/physics/PBL/SHOC/shoc.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = shoc type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../tools/funcphys.f90,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/ysuvdif.F90 b/physics/PBL/YSU/ysuvdif.F90 similarity index 100% rename from physics/ysuvdif.F90 rename to physics/PBL/YSU/ysuvdif.F90 diff --git a/physics/ysuvdif.meta b/physics/PBL/YSU/ysuvdif.meta similarity index 99% rename from physics/ysuvdif.meta rename to physics/PBL/YSU/ysuvdif.meta index 0007197bd..20e96a92d 100644 --- a/physics/ysuvdif.meta +++ b/physics/PBL/YSU/ysuvdif.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = ysuvdif type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/mfpbl.f b/physics/PBL/mfpbl.f similarity index 100% rename from physics/mfpbl.f rename to physics/PBL/mfpbl.f diff --git a/physics/mfpblt.f b/physics/PBL/mfpblt.f similarity index 100% rename from physics/mfpblt.f rename to physics/PBL/mfpblt.f diff --git a/physics/mfpbltq.f b/physics/PBL/mfpbltq.f similarity index 100% rename from physics/mfpbltq.f rename to physics/PBL/mfpbltq.f diff --git a/physics/shinhongvdif.F90 b/physics/PBL/saYSU/shinhongvdif.F90 similarity index 100% rename from physics/shinhongvdif.F90 rename to physics/PBL/saYSU/shinhongvdif.F90 diff --git a/physics/shinhongvdif.meta b/physics/PBL/saYSU/shinhongvdif.meta similarity index 99% rename from physics/shinhongvdif.meta rename to physics/PBL/saYSU/shinhongvdif.meta index dcd3b96cd..8b1d48605 100644 --- a/physics/shinhongvdif.meta +++ b/physics/PBL/saYSU/shinhongvdif.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = shinhongvdif type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/tridi.f b/physics/PBL/tridi.f similarity index 100% rename from physics/tridi.f rename to physics/PBL/tridi.f diff --git a/physics/iounitdef.f b/physics/Radiation/RRTMG/iounitdef.f similarity index 100% rename from physics/iounitdef.f rename to physics/Radiation/RRTMG/iounitdef.f diff --git a/physics/module_bfmicrophysics.f b/physics/Radiation/RRTMG/module_bfmicrophysics.f similarity index 100% rename from physics/module_bfmicrophysics.f rename to physics/Radiation/RRTMG/module_bfmicrophysics.f diff --git a/physics/rad_sw_pre.F90 b/physics/Radiation/RRTMG/rad_sw_pre.F90 similarity index 100% rename from physics/rad_sw_pre.F90 rename to physics/Radiation/RRTMG/rad_sw_pre.F90 diff --git a/physics/rad_sw_pre.meta b/physics/Radiation/RRTMG/rad_sw_pre.meta similarity index 96% rename from physics/rad_sw_pre.meta rename to physics/Radiation/RRTMG/rad_sw_pre.meta index ccbdbf74b..9d14c6ffc 100644 --- a/physics/rad_sw_pre.meta +++ b/physics/Radiation/RRTMG/rad_sw_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rad_sw_pre type = scheme - dependencies = iounitdef.f,machine.F + dependencies = iounitdef.f,../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/radcons.f90 b/physics/Radiation/RRTMG/radcons.f90 similarity index 100% rename from physics/radcons.f90 rename to physics/Radiation/RRTMG/radcons.f90 diff --git a/physics/radlw_datatb.f b/physics/Radiation/RRTMG/radlw_datatb.f similarity index 100% rename from physics/radlw_datatb.f rename to physics/Radiation/RRTMG/radlw_datatb.f diff --git a/physics/radlw_main.F90 b/physics/Radiation/RRTMG/radlw_main.F90 similarity index 100% rename from physics/radlw_main.F90 rename to physics/Radiation/RRTMG/radlw_main.F90 diff --git a/physics/radlw_main.meta b/physics/Radiation/RRTMG/radlw_main.meta similarity index 99% rename from physics/radlw_main.meta rename to physics/Radiation/RRTMG/radlw_main.meta index 3dccc97b3..f7c80fb20 100644 --- a/physics/radlw_main.meta +++ b/physics/Radiation/RRTMG/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,radlw_datatb.f,radlw_param.f + dependencies = ../../hooks/machine.F,../mersenne_twister.f,../../hooks/physcons.F90,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/radlw_param.f b/physics/Radiation/RRTMG/radlw_param.f similarity index 100% rename from physics/radlw_param.f rename to physics/Radiation/RRTMG/radlw_param.f diff --git a/physics/radlw_param.meta b/physics/Radiation/RRTMG/radlw_param.meta similarity index 100% rename from physics/radlw_param.meta rename to physics/Radiation/RRTMG/radlw_param.meta diff --git a/physics/radsw_datatb.f b/physics/Radiation/RRTMG/radsw_datatb.f similarity index 100% rename from physics/radsw_datatb.f rename to physics/Radiation/RRTMG/radsw_datatb.f diff --git a/physics/radsw_main.F90 b/physics/Radiation/RRTMG/radsw_main.F90 similarity index 100% rename from physics/radsw_main.F90 rename to physics/Radiation/RRTMG/radsw_main.F90 diff --git a/physics/radsw_main.meta b/physics/Radiation/RRTMG/radsw_main.meta similarity index 99% rename from physics/radsw_main.meta rename to physics/Radiation/RRTMG/radsw_main.meta index 1edb6fcac..2169a26f0 100644 --- a/physics/radsw_main.meta +++ b/physics/Radiation/RRTMG/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,radsw_datatb.f,radsw_param.f + dependencies = ../../hooks/machine.F,../mersenne_twister.f,../../hooks/physcons.F90,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/radsw_param.f b/physics/Radiation/RRTMG/radsw_param.f similarity index 100% rename from physics/radsw_param.f rename to physics/Radiation/RRTMG/radsw_param.f diff --git a/physics/radsw_param.meta b/physics/Radiation/RRTMG/radsw_param.meta similarity index 100% rename from physics/radsw_param.meta rename to physics/Radiation/RRTMG/radsw_param.meta diff --git a/physics/rrtmg_lw_cloud_optics.F90 b/physics/Radiation/RRTMG/rrtmg_lw_cloud_optics.F90 similarity index 100% rename from physics/rrtmg_lw_cloud_optics.F90 rename to physics/Radiation/RRTMG/rrtmg_lw_cloud_optics.F90 diff --git a/physics/rrtmg_lw_post.F90 b/physics/Radiation/RRTMG/rrtmg_lw_post.F90 similarity index 100% rename from physics/rrtmg_lw_post.F90 rename to physics/Radiation/RRTMG/rrtmg_lw_post.F90 diff --git a/physics/rrtmg_lw_post.meta b/physics/Radiation/RRTMG/rrtmg_lw_post.meta similarity index 99% rename from physics/rrtmg_lw_post.meta rename to physics/Radiation/RRTMG/rrtmg_lw_post.meta index 7f219c24f..6ed7c2365 100644 --- a/physics/rrtmg_lw_post.meta +++ b/physics/Radiation/RRTMG/rrtmg_lw_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw_post type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmg_sw_cloud_optics.F90 b/physics/Radiation/RRTMG/rrtmg_sw_cloud_optics.F90 similarity index 100% rename from physics/rrtmg_sw_cloud_optics.F90 rename to physics/Radiation/RRTMG/rrtmg_sw_cloud_optics.F90 diff --git a/physics/rrtmg_sw_post.F90 b/physics/Radiation/RRTMG/rrtmg_sw_post.F90 similarity index 100% rename from physics/rrtmg_sw_post.F90 rename to physics/Radiation/RRTMG/rrtmg_sw_post.F90 diff --git a/physics/rrtmg_sw_post.meta b/physics/Radiation/RRTMG/rrtmg_sw_post.meta similarity index 99% rename from physics/rrtmg_sw_post.meta rename to physics/Radiation/RRTMG/rrtmg_sw_post.meta index 6a9f4efb5..9914051ce 100644 --- a/physics/rrtmg_sw_post.meta +++ b/physics/Radiation/RRTMG/rrtmg_sw_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw_post type = scheme - dependencies = machine.F,radsw_param.f + dependencies = ../../hooks/machine.F,radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.F90 similarity index 100% rename from physics/rrtmgp_aerosol_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.F90 diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.meta similarity index 98% rename from physics/rrtmgp_aerosol_optics.meta rename to physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.meta index cc9eb1cc2..37ec2e9a0 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmgp_aerosol_optics type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 + dependencies = ../../hooks/machine.F,../radiation_aerosols.f,../radiation_tools.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_lw_cloud_optics.F90 similarity index 100% rename from physics/rrtmgp_lw_cloud_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_lw_cloud_optics.F90 diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_lw_gas_optics.F90 similarity index 100% rename from physics/rrtmgp_lw_gas_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_lw_gas_optics.F90 diff --git a/physics/rrtmgp_lw_main.F90 b/physics/Radiation/RRTMGP/rrtmgp_lw_main.F90 similarity index 100% rename from physics/rrtmgp_lw_main.F90 rename to physics/Radiation/RRTMGP/rrtmgp_lw_main.F90 diff --git a/physics/rrtmgp_lw_main.meta b/physics/Radiation/RRTMGP/rrtmgp_lw_main.meta similarity index 98% rename from physics/rrtmgp_lw_main.meta rename to physics/Radiation/RRTMGP/rrtmgp_lw_main.meta index ca8a117dc..572e67d94 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/Radiation/RRTMGP/rrtmgp_lw_main.meta @@ -1,12 +1,13 @@ [ccpp-table-properties] name = rrtmgp_lw_main type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = ../../hooks/machine.F,../radiation_tools.F90,../mersenne_twister.f + dependencies = rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 dependencies = rte-rrtmgp/rte/mo_source_functions.F90,rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_fluxes.F90 dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 - dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - dependencies = rrtmgp_lw_gas_optics.F90, rrtmgp_lw_cloud_optics.F90 + dependencies = rrtmgp_lw_gas_optics.F90, rrtmgp_lw_cloud_optics.F90,rrtmgp_sampling.F90 + dependencies = ../../Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmgp_sampling.F90 b/physics/Radiation/RRTMGP/rrtmgp_sampling.F90 similarity index 100% rename from physics/rrtmgp_sampling.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sampling.F90 diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_sw_cloud_optics.F90 similarity index 100% rename from physics/rrtmgp_sw_cloud_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sw_cloud_optics.F90 diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/Radiation/RRTMGP/rrtmgp_sw_gas_optics.F90 similarity index 100% rename from physics/rrtmgp_sw_gas_optics.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sw_gas_optics.F90 diff --git a/physics/rrtmgp_sw_main.F90 b/physics/Radiation/RRTMGP/rrtmgp_sw_main.F90 similarity index 100% rename from physics/rrtmgp_sw_main.F90 rename to physics/Radiation/RRTMGP/rrtmgp_sw_main.F90 diff --git a/physics/rrtmgp_sw_main.meta b/physics/Radiation/RRTMGP/rrtmgp_sw_main.meta similarity index 98% rename from physics/rrtmgp_sw_main.meta rename to physics/Radiation/RRTMGP/rrtmgp_sw_main.meta index dbb93a5df..711d01bc1 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/Radiation/RRTMGP/rrtmgp_sw_main.meta @@ -1,12 +1,13 @@ [ccpp-table-properties] name = rrtmgp_sw_main type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = ../../hooks/machine.F,../radiation_tools.F90,../mersenne_twister.f + dependencies = rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 dependencies = rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90 dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 - dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - dependencies = rrtmgp_sw_gas_optics.F90, rrtmgp_sw_cloud_optics.F90 + dependencies = rrtmgp_sw_gas_optics.F90, rrtmgp_sw_cloud_optics.F90,rrtmgp_sampling.F90 + dependencies = ../../Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/Radiation/RRTMGP/rte-rrtmgp b/physics/Radiation/RRTMGP/rte-rrtmgp new file mode 160000 index 000000000..74a0e098b --- /dev/null +++ b/physics/Radiation/RRTMGP/rte-rrtmgp @@ -0,0 +1 @@ +Subproject commit 74a0e098b2163425e4b5466c2dfcf8ae26d560a5 diff --git a/physics/mersenne_twister.f b/physics/Radiation/mersenne_twister.f similarity index 100% rename from physics/mersenne_twister.f rename to physics/Radiation/mersenne_twister.f diff --git a/physics/radiation_aerosols.f b/physics/Radiation/radiation_aerosols.f similarity index 100% rename from physics/radiation_aerosols.f rename to physics/Radiation/radiation_aerosols.f diff --git a/physics/radiation_astronomy.f b/physics/Radiation/radiation_astronomy.f similarity index 100% rename from physics/radiation_astronomy.f rename to physics/Radiation/radiation_astronomy.f diff --git a/physics/radiation_cloud_overlap.F90 b/physics/Radiation/radiation_cloud_overlap.F90 similarity index 100% rename from physics/radiation_cloud_overlap.F90 rename to physics/Radiation/radiation_cloud_overlap.F90 diff --git a/physics/radiation_clouds.f b/physics/Radiation/radiation_clouds.f similarity index 100% rename from physics/radiation_clouds.f rename to physics/Radiation/radiation_clouds.f diff --git a/physics/radiation_gases.f b/physics/Radiation/radiation_gases.f similarity index 100% rename from physics/radiation_gases.f rename to physics/Radiation/radiation_gases.f diff --git a/physics/radiation_surface.f b/physics/Radiation/radiation_surface.f similarity index 100% rename from physics/radiation_surface.f rename to physics/Radiation/radiation_surface.f diff --git a/physics/radiation_tools.F90 b/physics/Radiation/radiation_tools.F90 similarity index 100% rename from physics/radiation_tools.F90 rename to physics/Radiation/radiation_tools.F90 diff --git a/physics/gfdl_sfc_layer.F90 b/physics/SFC_Layer/GFDL/gfdl_sfc_layer.F90 similarity index 100% rename from physics/gfdl_sfc_layer.F90 rename to physics/SFC_Layer/GFDL/gfdl_sfc_layer.F90 diff --git a/physics/gfdl_sfc_layer.meta b/physics/SFC_Layer/GFDL/gfdl_sfc_layer.meta similarity index 99% rename from physics/gfdl_sfc_layer.meta rename to physics/SFC_Layer/GFDL/gfdl_sfc_layer.meta index f1c7a4ce2..ac98437e9 100644 --- a/physics/gfdl_sfc_layer.meta +++ b/physics/SFC_Layer/GFDL/gfdl_sfc_layer.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = gfdl_sfc_layer type = scheme - dependencies = machine.F,module_sf_exchcoef.f90,namelist_soilveg_ruc.F90,noahmp_tables.f90 + dependencies = ../../hooks/machine.F,module_sf_exchcoef.f90 + dependencies = ../../SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 + dependencies = ../../SFC_Models/Land/Noahmp/noahmp_tables.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_sf_exchcoef.f90 b/physics/SFC_Layer/GFDL/module_sf_exchcoef.f90 similarity index 100% rename from physics/module_sf_exchcoef.f90 rename to physics/SFC_Layer/GFDL/module_sf_exchcoef.f90 diff --git a/physics/module_SF_JSFC.F90 b/physics/SFC_Layer/MYJ/module_SF_JSFC.F90 similarity index 100% rename from physics/module_SF_JSFC.F90 rename to physics/SFC_Layer/MYJ/module_SF_JSFC.F90 diff --git a/physics/myjsfc_wrapper.F90 b/physics/SFC_Layer/MYJ/myjsfc_wrapper.F90 similarity index 100% rename from physics/myjsfc_wrapper.F90 rename to physics/SFC_Layer/MYJ/myjsfc_wrapper.F90 diff --git a/physics/myjsfc_wrapper.meta b/physics/SFC_Layer/MYJ/myjsfc_wrapper.meta similarity index 99% rename from physics/myjsfc_wrapper.meta rename to physics/SFC_Layer/MYJ/myjsfc_wrapper.meta index 40b6b78f3..0ae09985e 100644 --- a/physics/myjsfc_wrapper.meta +++ b/physics/SFC_Layer/MYJ/myjsfc_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = myjsfc_wrapper type = scheme - dependencies = module_SF_JSFC.F90 + dependencies = ../../hooks/machine.F,module_SF_JSFC.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_sf_mynn.F90 b/physics/SFC_Layer/MYNN/module_sf_mynn.F90 similarity index 99% rename from physics/module_sf_mynn.F90 rename to physics/SFC_Layer/MYNN/module_sf_mynn.F90 index eecc5493c..3d847348d 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/SFC_Layer/MYNN/module_sf_mynn.F90 @@ -26,7 +26,7 @@ MODULE module_sf_mynn ! ! LAND only: ! "iz0tlnd" namelist option is used to select the following momentum options: -! (default) =0: Zilitinkevich (1995); Czil now set to 0.085 +! (default) =0: Zilitinkevich (1995); Czil now set to 0.095 ! =1: Czil_new (modified according to Chen & Zhang 2008) ! =2: Modified Yang et al (2002, 2008) - generalized for all landuse ! =3: constant zt = z0/7.4 (original form; Garratt 1992) @@ -225,7 +225,7 @@ SUBROUTINE SFCLAY_mynn( & ! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0/3.5 ! only) =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) ! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 -!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.085, +!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.095, ! (land =1: Czil_new (modified according to Chen & Zhang 2008) ! only) =2: Modified Yang et al (2002, 2008) - generalized for all landuse ! =3: constant zt = z0/7.4 (Garratt 1992) @@ -947,7 +947,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K) THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*qsfc_lnd(I)) - if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 360.) & + if(THVSK_lnd(I) < 160. .or. THVSK_lnd(I) > 390.) & print *,'THVSK_lnd(I)',itimestep,i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i) endif if(icy(i)) then @@ -956,7 +956,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_ice(I) = TSK_ice(I)*THCON(I) !(K) THVSK_ice(I) = THSK_ice(I)*(1.+EP1*qsfc_ice(I)) !(K) - if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 360.) & + if(THVSK_ice(I) < 160. .or. THVSK_ice(I) > 390.) & print *,'THVSK_ice(I)',itimestep,i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i) endif if(wet(i)) then @@ -965,7 +965,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_wat(I) = TSK_wat(I)*THCON(I) !(K) THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K) - if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 360.) & + if(THVSK_wat(I) < 160. .or. THVSK_wat(I) > 390.) & print *,'THVSK_wat(I)',i,THVSK_wat(I),THSK_wat(i),tsurf_wat(i),tskin_wat(i),qsfc_wat(i) endif endif ! flag_iter @@ -1380,6 +1380,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & else ZNTstoch_lnd(I) = ZNT_lnd(I) endif + !add limit to prevent ridiculous values of z0 (more than dz/15) + ZNTstoch_lnd(I) = min(ZNTstoch_lnd(I), dz8w1d(i)*0.0666_kind_phys) !-------------------------------------- ! LAND @@ -2604,7 +2606,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& IF ( IZ0TLND2 .EQ. 1 ) THEN CZIL = 10.0 ** ( -0.40 * ( Z_0 / 0.07 ) ) ELSE - CZIL = 0.085 !0.075 !0.10 + CZIL = 0.095 !0.075 !0.10 END IF Zt = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) diff --git a/physics/mynnsfc_wrapper.F90 b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 similarity index 100% rename from physics/mynnsfc_wrapper.F90 rename to physics/SFC_Layer/MYNN/mynnsfc_wrapper.F90 diff --git a/physics/mynnsfc_wrapper.meta b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta similarity index 99% rename from physics/mynnsfc_wrapper.meta rename to physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta index d89cc5d35..0e1c96c02 100644 --- a/physics/mynnsfc_wrapper.meta +++ b/physics/SFC_Layer/MYNN/mynnsfc_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = mynnsfc_wrapper type = scheme - dependencies = machine.F,module_sf_mynn.F90 + dependencies = ../../hooks/machine.F,../../hooks/physcons.F90,module_sf_mynn.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/date_def.f b/physics/SFC_Layer/UFS/date_def.f similarity index 100% rename from physics/date_def.f rename to physics/SFC_Layer/UFS/date_def.f diff --git a/physics/SFC_Layer/UFS/module_nst_model.f90 b/physics/SFC_Layer/UFS/module_nst_model.f90 new file mode 100644 index 000000000..74c75924b --- /dev/null +++ b/physics/SFC_Layer/UFS/module_nst_model.f90 @@ -0,0 +1,976 @@ +!>\file module_nst_model.f90 +!! This file contains the diurnal thermocline layer model (DTM) of +!! the GFS NSST scheme. + +!>\defgroup dtm_module GFS NSST Diurnal Thermocline Model +!> This module contains the diurnal thermocline layer model (DTM) of +!! the GFS NSST scheme. +!>\ingroup gfs_nst_main_mod + +!> This module contains the diurnal thermocline layer model (DTM) of +!! the GFS NSST scheme. +module nst_module + ! + ! the module of diurnal thermocline layer model + ! + use machine , only : kind_phys + use module_nst_parameters , only : z_w_max, z_w_min, z_w_ini, eps_z_w, eps_conv + use module_nst_parameters , only : eps_sfs, niter_z_w, niter_conv, niter_sfs, ri_c + use module_nst_parameters , only : ri_g, omg_m, omg_sh, kw => tc_w, visw, t0k, cp_w + use module_nst_parameters , only : z_c_max, z_c_ini, ustar_a_min, delz, exp_const + use module_nst_parameters , only : rad2deg, const_rot, tw_max, sst_max + use module_nst_parameters , only : zero, one + use module_nst_water_prop , only : sw_rad_skin, sw_ps_9b, sw_ps_9b_aw + + implicit none + + private + + public :: dtm_1p, dtm_1p_fca, dtm_1p_tla, dtm_1p_mwa, dtm_1p_mda, dtm_1p_mta, convdepth + public :: cal_w, cal_ttop, cool_skin, dtl_reset + +contains + + !>\ingroup gfs_nst_main_mod + !! This subroutine contains the module of diurnal thermocline layer model. + subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & + alpha,beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& + hl_ts,rho,alpha,beta,alon,sinlat,soltim,& + grav,le,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts + ! local variables + + ! + ! input variables + ! + ! timestep: integration time step in seconds + ! rich : critical ri (flow dependent) + ! tox : x wind stress (n*m^-2 or kg/m/s^2) + ! toy : y wind stress (n*m^-2 or kg/m/s^2) + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes + ! hl_ts : d(hl)/d(ts) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! sinlat : sine (lat) + ! grav : gravity accelleration + ! le : le=(2.501-.00237*tsea)*1e6 + ! d-conv : fcl thickness + ! + ! inout variables + ! + ! xt : dtl heat content (m*k) + ! xs : dtl salinity content (m*ppt) + ! xu : dtl x current content (m*m/s) + ! xv : dtl y current content (m*m/s) + ! xz : dtl thickness (m) + ! xzts : d(xz)/d(ts) (m/k ) + ! xtts : d(xt)/d(ts) (m) + ! + ! logical lprnt + + ! if (lprnt) print *,' first xt=',xt + if ( xt <= zero ) then ! dtl doesn't exist yet + call dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & + beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) + elseif ( xt > zero ) then ! dtl already exists + ! + ! forward the system one time step + ! + call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & + beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + endif ! if ( xt == 0 ) then + + end subroutine dtm_1p + + !>\ingroup gfs_nst_main_mod + !! This subroutine integrates one time step with modified Euler method. + subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & + beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + + ! + ! subroutine eulerm: integrate one time step with modified euler method + ! + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts, & + hl_ts,rho,alpha,beta,alon,sinlat,soltim, & + grav,le,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts + ! local variables + real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0 + real(kind=kind_phys) :: fw,aw,q_warm + real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1,xzts1,xtts1 + real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2 + real(kind=kind_phys) :: dzw,drho,fc + real(kind=kind_phys) :: alat,speed + ! logical lprnt + + ! + ! input variables + ! + ! timestep: integration time step in seconds + ! rich : critial ri (flow/mass dependent) + ! tox : x wind stress (n*m^-2 or kg/m/s^2) + ! toy : y wind stress (n*m^-2 or kg/m/s^2) + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes + ! hl_ts : d(hl)/d(ts) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! alon : longitude (deg) + ! sinlat : sine (lat) + ! soltim : solar time + ! grav : gravity accelleration + ! le : le=(2.501-.00237*tsea)*1e6 + ! d_conv : fcl thickness (m) + ! + ! inout variables + ! + ! xt : dtl heat content (m*k) + ! xs : dtl salinity content (m*ppt) + ! xu : dtl x current content (m*m/s) + ! xv : dtl y current content (m*m/s) + ! xz : dtl thickness (m) + ! xzts : d(xz)/d(ts) (m/k ) + ! xtts : d(xt)/d(ts) (m) + + xt0 = xt + xs0 = xs + xu0 = xu + xv0 = xv + xz0 = xz + xtts0 = xtts + xzts0 = xzts + speed = max(1.0e-8, xu0*xu0+xv0*xv0) + + alat = asin(sinlat)*rad2deg + + fc = const_rot*sinlat + + call sw_ps_9b(xz0,fw) + + q_warm = fw*i0-q !total heat abs in warm layer + + call sw_ps_9b_aw(xz0,aw) + + drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep + + ! dzw = xz0*(tox*xu0+toy*xv0) / (rho*(xu0*xu0+xv0*xv0)) & + ! + xz0*xz0*xz0*drho*grav / (4.0*rich*(xu0*xu0+xv0*xv0)) + dzw = xz0 * ((tox*xu0+toy*xv0) / (rho*speed) & + + xz0*xz0*drho*grav / (4.0*rich*speed)) + + xt1 = xt0 + timestep*q_warm/(rho*cp_w) + xs1 = xs0 + timestep*sep + xu1 = xu0 + timestep*(fc*xv0+tox/rho) + xv1 = xv0 + timestep*(-fc*xu0+toy/rho) + xz1 = xz0 + timestep*dzw + + ! if (lprnt) print *,' xt1=',xt1,' xz1=',xz1,' xz0=',xz0,' dzw=',dzw, & + ! 'timestep=',timestep,tox,toy,xu0,xv0,rho,drho,grav,rich + + if ( xt1 <= zero .or. xz1 <= zero .or. xz1 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + return + endif + + ! call dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt1,xs1,xu1,xv1,xz1,tr_mda,tr_fca,tr_tla,tr_mwa) + + xzts1 = xzts0 + timestep*((1.0/(xu0*xu0+xv0*xv0)) * & + ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz0**3/(4.0*rich*rho) & + +( (tox*xu0+toy*xv0)/rho+(3.0*drho-alpha*i0*aw*xz0/(rho*cp_w)) & + *grav*xz0*xz0/(4.0*rich) )*xzts0 )) + xtts1 = xtts0 + timestep*(i0*aw*xzts0-q_ts)/(rho*cp_w) + + ! if ( 2.0*xt1/xz1 > 0.001 ) then + ! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_01 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& + ! 2.0*xt1/xz1,2.0*xs1/xz1,2.0*xu1/xz1,2.0*xv1/xz1,xz1,xtts1,xzts1,d_conv,t_fcl,te + ! endif + + call sw_ps_9b(xz1,fw) + q_warm = fw*i0-q !total heat abs in warm layer + call sw_ps_9b_aw(xz1,aw) + drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep + dzw = xz1*(tox*xu1+toy*xv1) / (rho*(xu1*xu1+xv1*xv1)) & + + xz1*xz1*xz1*drho*grav / (4.0*rich*(xu1*xu1+xv1*xv1)) + + xt2 = xt0 + timestep*q_warm/(rho*cp_w) + xs2 = xs0 + timestep*sep + xu2 = xu0 + timestep*(fc*xv1+tox/rho) + xv2 = xv0 + timestep*(-fc*xu1+toy/rho) + xz2 = xz0 + timestep*dzw + + ! if (lprnt) print *,' xt2=',xt2,' xz2=',xz2 + + if ( xt2 <= zero .or. xz2 <= zero .or. xz2 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + return + endif + + xzts2 = xzts0 + timestep*((1.0/(xu1*xu1+xv1*xv1)) * & + ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz1**3/(4.0*rich*rho) & + +( (tox*xu1+toy*xv1)/rho+(3.0*drho-alpha*i0*aw*xz1/(rho*cp_w))* & + grav*xz1*xz1/(4.0*rich) )*xzts1 )) + xtts2 = xtts0 + timestep*(i0*aw*xzts1-q_ts)/(rho*cp_w) + + xt = 0.5*(xt1 + xt2) + xs = 0.5*(xs1 + xs2) + xu = 0.5*(xu1 + xu2) + xv = 0.5*(xv1 + xv2) + xz = 0.5*(xz1 + xz2) + xzts = 0.5*(xzts1 + xzts2) + xtts = 0.5*(xtts1 + xtts2) + + if ( xt <= zero .or. xz < zero .or. xz > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + endif + + ! if (lprnt) print *,' xt=',xt,' xz=',xz + ! if ( 2.0*xt/xz > 0.001 ) then + ! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_02 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& + ! 2.0*xt/xz,2.0*xs/xz,2.0*xu/xz,2.0*xv/xz,xz,xtts,xzts,d_conv,t_fcl,te + ! endif + return + + end subroutine eulerm + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies xz adjustment. + subroutine dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt,xs,xu,xv,xz,tr_mda,tr_fca,tr_tla,tr_mwa) + ! apply xz adjustment: minimum depth adjustment (mda) + ! free convection adjustment (fca); + ! top layer adjustment (tla); + ! maximum warming adjustment (mwa) + ! + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,i0,q,rho,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz + real(kind=kind_phys), intent(out) :: tr_mda,tr_fca,tr_tla,tr_mwa + ! local variables + real(kind=kind_phys) :: dz,t0,ttop0,ttop,fw,q_warm + ! TODO: xz_mwa is unset but used below in max function + real(kind=kind_phys) :: xz_fca,xz_tla,xz_mwa + ! + real(kind=kind_phys) :: xz_mda + + tr_mda = zero; tr_fca = zero; tr_tla = zero; tr_mwa = zero + + ! apply mda + if ( z_w_min > xz ) then + xz_mda = z_w_min + endif + ! apply fca + if ( d_conv > zero ) then + xz_fca = 2.0*xt/((2.0*xt/xz)*(1.0-d_conv/(2.0*xz))) + tr_fca = 1.0 + if ( xz_fca >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + ! apply tla + dz = min(xz,max(d_conv,delz)) + call sw_ps_9b(dz,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + if ( q_warm > zero ) then + call cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop0) + ! ttop = (2.0*xt/xz)*(1.0-dz/(2.0*xz)) + ttop = ((xt+xt)/xz)*(1.0-dz/(xz+xz)) + if ( ttop > ttop0 ) then + xz_tla = (xt+sqrt(xt*(xt-delz*ttop0)))/ttop0 + tr_tla = 1.0 + if ( xz_tla >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + endif + + ! apply mwa + t0 = 2.0*xt/xz + if ( t0 > tw_max ) then + if ( xz >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + + xz = max(xz_mda,xz_fca,xz_tla,xz_mwa) + +10 continue + + end subroutine dtm_1p_zwa + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies free convection adjustment(fca). + subroutine dtm_1p_fca(d_conv,xt,xtts,xz,xzts) + + ! apply xz adjustment: free convection adjustment (fca); + ! + real(kind=kind_phys), intent(in) :: d_conv,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: t_fcl,t0 + ! + t0 = 2.0*xt/xz + t_fcl = t0*(1.0-d_conv/(2.0*xz)) + xz = 2.0*xt/t_fcl + ! xzts = 2.0*xtts/t_fcl + + end subroutine dtm_1p_fca + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies top layer adjustment (tla). + subroutine dtm_1p_tla(dz,te,xt,xtts,xz,xzts) + + ! apply xz adjustment: top layer adjustment (tla); + ! + real(kind=kind_phys), intent(in) :: dz,te,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: tem + ! + tem = xt*(xt-dz*te) + if (tem > zero) then + xz = (xt+sqrt(xt*(xt-dz*te)))/te + else + xz = z_w_max + endif + ! xzts = xtts*(1.0+0.5*(2.0*xt-dz*te)/sqrt(xt*(xt-dz*te)))/te + end subroutine dtm_1p_tla + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies maximum warming adjustment (mwa). + subroutine dtm_1p_mwa(xt,xtts,xz,xzts) + + ! apply xz adjustment: maximum warming adjustment (mwa) + ! + real(kind=kind_phys), intent(in) :: xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + ! + xz = 2.0*xt/tw_max + ! xzts = 2.0*xtts/tw_max + end subroutine dtm_1p_mwa + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies minimum depth adjustment (xz adjustment). + subroutine dtm_1p_mda(xt,xtts,xz,xzts) + + ! apply xz adjustment: minimum depth adjustment (mda) + ! + real(kind=kind_phys), intent(in) :: xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: ta + ! + xz = max(z_w_min,xz) + ta = 2.0*xt/xz + ! xzts = 2.0*xtts/ta + + end subroutine dtm_1p_mda + + !>\ingroup gfs_nst_main_mod + !! This subroutine applies maximum temperature adjustment (mta). + subroutine dtm_1p_mta(dta,xt,xtts,xz,xzts) + + ! apply xz adjustment: maximum temperature adjustment (mta) + ! + real(kind=kind_phys), intent(in) :: dta,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts + ! local variables + real(kind=kind_phys) :: ta + ! + ta = max(zero,2.0*xt/xz-dta) + if ( ta > zero ) then + xz = 2.0*xt/ta + else + xz = z_w_max + endif + ! xzts = 2.0*xtts/ta + + end subroutine dtm_1p_mta + + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates depth for convective adjustment. + subroutine convdepth(kdt,timestep,i0,q,sss,sep,rho,alpha,beta,xt,xs,xz,d_conv) + + ! + ! calculate depth for convective adjustment + ! + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,i0,q,sss,sep,rho,alpha,beta + real(kind=kind_phys), intent(in) :: xt,xs,xz + real(kind=kind_phys), intent(out) :: d_conv + real(kind=kind_phys) :: t,s,d_conv_ini,d_conv2,fxp,aw,s1,s2,fac1 + integer :: n + ! + ! input variables + ! + ! timestep: time step in seconds + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! xt : initial heat content (k*m) + ! xs : initial salinity content (ppt*m) + ! xz : initial dtl thickness (m) + ! + ! output variables + ! + ! d_conv : free convection depth (m) + + ! t : initial diurnal warming t (k) + ! s : initial diurnal warming s (ppt) + + n = 0 + t = 2.0*xt/xz + s = 2.0*xs/xz + + s1 = alpha*rho*t-omg_m*beta*rho*s + + if ( s1 == zero ) then + d_conv = zero + else + + fac1 = alpha*q/cp_w+omg_m*beta*rho*sep + if ( i0 <= zero ) then + d_conv2=(2.0*xz*timestep/s1)*fac1 + if ( d_conv2 > zero ) then + d_conv = sqrt(d_conv2) + else + d_conv = zero + endif + elseif ( i0 > zero ) then + + d_conv_ini = zero + + iter_conv: do n = 1, niter_conv + call sw_ps_9b(d_conv_ini,fxp) + call sw_ps_9b_aw(d_conv_ini,aw) + s2 = alpha*(q-(fxp-aw*d_conv_ini)*i0)/cp_w+omg_m*beta*rho*sep + d_conv2=(2.0*xz*timestep/s1)*s2 + if ( d_conv2 < zero ) then + d_conv = zero + exit iter_conv + endif + d_conv = sqrt(d_conv2) + if ( abs(d_conv-d_conv_ini) < eps_conv .and. n <= niter_conv ) exit iter_conv + d_conv_ini = d_conv + enddo iter_conv + d_conv = max(zero,min(d_conv,z_w_max)) + endif ! if ( i0 <= zero ) then + + endif ! if ( s1 == zero ) then + + ! if ( d_conv > 0.01 ) then + ! write(*,'(a,i4,i3,10f9.3,3f10.6,f10.1,f6.2)') ' d_conv : ',kdt,n,d_conv,d_conv_ini,q,i0,rho,cp_w,timestep,xt,xs,xz,sep, & + ! s1,s2,d_conv2,aw + ! endif + + end subroutine convdepth + + !>\ingroup gfs_nst_main_mod + subroutine dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & + alpha,beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) + ! + ! determine xz iteratively (starting wit fw = 0.5) and then update the other 6 variables + ! + + integer,intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts, & + hl_ts,rho,alpha,beta,alon,sinlat,soltim,grav,le + real(kind=kind_phys), intent(out) :: xt,xs,xu,xv,xz,xzts,xtts + real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0 + real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1 + real(kind=kind_phys) :: fw,aw,q_warm,ft0,fs0,fu0,fv0,fz0,ft1,fs1,fu1,fv1,fz1 + real(kind=kind_phys) :: coeff1,coeff2,ftime,z_w,z_w_tmp,fc,warml,alat + integer :: n + ! + ! input variables + ! + ! timestep: time step in seconds + ! tox : x wind stress (n*m^-2 or kg/m/s^2) + ! toy : y wind stress (n*m^-2 or kg/m/s^2) + ! i0 : solar radiation flux at the surface (wm^-2) + ! q : non-solar heat flux at the surface (wm^-2) + ! sss : salinity (ppt) + ! sep : sr(e-p) (ppt*m/s) + ! rho : sea water density (kg*m^-3) + ! alpha : thermal expansion coefficient (1/k) + ! beta : saline contraction coefficient (1/ppt) + ! alon : longitude + ! sinlat : sine(latitude) + ! grav : gravity accelleration + ! le : le=(2.501-.00237*tsea)*1e6 + ! + ! output variables + ! + ! xt : onset t content in dtl + ! xs : onset s content in dtl + ! xu : onset u content in dtl + ! xv : onset v content in dtl + ! xz : onset dtl thickness (m) + ! xzts : onset d(xz)/d(ts) (m/k ) + ! xtts : onset d(xt)/d(ts) (m) + + fc=1.46/10000.0/2.0*sinlat + alat = asin(sinlat) + ! + ! initializing dtl (just before the onset) + ! + xt0 = zero + xs0 = zero + xu0 = zero + xv0 = zero + + z_w_tmp=z_w_ini + + call sw_ps_9b(z_w_tmp,fw) + ! fw=0.5 ! + q_warm=fw*i0-q !total heat abs in warm layer + + if ( abs(alat) > 1.0 ) then + ftime=sqrt((2.0-2.0*cos(fc*timestep))/(fc*fc*timestep)) + else + ftime=timestep + endif + + coeff1=alpha*grav/cp_w + coeff2=omg_m*beta*grav*rho + warml = coeff1*q_warm-coeff2*sep + + if ( warml > zero .and. q_warm > zero) then + iters_z_w: do n = 1,niter_z_w + if ( warml > zero .and. q_warm > zero ) then + z_w=sqrt(2.0*rich*ftime/rho)*sqrt(tox**2+toy**2)/sqrt(warml) + else + z_w = z_w_max + exit iters_z_w + endif + + ! write(*,'(a,i4,i4,10f9.3,f9.6,f3.0)') ' z_w = ',kdt,n,z_w,z_w_tmp,timestep,q_warm,q,i0,fw,tox,toy,sep,warml,omg_m + + if (abs(z_w - z_w_tmp) < eps_z_w .and. z_w/=z_w_max .and. n < niter_z_w) exit iters_z_w + z_w_tmp=z_w + call sw_ps_9b(z_w_tmp,fw) + q_warm = fw*i0-q + warml = coeff1*q_warm-coeff2*sep + end do iters_z_w + else + z_w=z_w_max + endif + + xz0 = max(z_w,z_w_min) + + ! + ! update xt, xs, xu, xv + ! + if ( z_w < z_w_max .and. q_warm > zero) then + + call sw_ps_9b(z_w,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + ft0 = q_warm/(rho*cp_w) + fs0 = sep + fu0 = fc*xv0+tox/rho + fv0 = -fc*xu0+toy/rho + + xt1 = xt0 + timestep*ft0 + xs1 = xs0 + timestep*fs0 + xu1 = xu0 + timestep*fu0 + xv1 = xv0 + timestep*fv0 + + fz0 = xz0*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz0*xz0/(4.0*rich) & + -alpha*grav*q_warm*xz0*xz0/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) + xz1 = xz0 + timestep*fz0 + + xz1 = max(xz1,z_w_min) + + if ( xt1 < zero .or. xz1 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) + return + endif + + call sw_ps_9b(xz1,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + ft1 = q_warm/(rho*cp_w) + fs1 = sep + fu1 = fc*xv1+tox/rho + fv1 = -fc*xu1+toy/rho + + fz1 = xz1*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz1*xz1/(4.0*rich) & + -alpha*grav*q_warm*xz1*xz1/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) + + xt = xt0 + 0.5*timestep*(ft0+ft1) + xs = xs0 + 0.5*timestep*(fs0+fs1) + xu = xu0 + 0.5*timestep*(fu0+fu1) + xv = xv0 + 0.5*timestep*(fv0+fv1) + xz = xz0 + 0.5*timestep*(fz0+fz1) + + xz = max(xz,z_w_min) + + call sw_ps_9b_aw(xz,aw) + + ! xzts = (q_ts+(cp_w*omg_m*beta*sss/(le*alpha))*hl_ts)*xz/(i0*xz*aw+2.0*q_warm-2.0*(rho*cp_w*omg_m*beta*sss/alpha)*(sep/sss)) + xzts = (q_ts+omg_m*rho*cp_w*beta*sss*hl_ts*xz/(le*alpha))/(i0*xz*aw+2.0*q_warm-2.0*omg_m*rho*cp_w*beta*sss*sep/(le*alpha)) + xtts = timestep*(i0*aw*xzts-q_ts)/(rho*cp_w) + endif + + if ( xt < zero .or. xz > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) + endif + + return + + end subroutine dtm_onset + + !>\ingroup gfs_nst_main_mod + !! This subroutine computes coefficients (\a w_0 and \a w_d) to + !! calculate d(tw)/d(ts). + subroutine cal_w(kdt,xz,xt,xzts,xtts,w_0,w_d) + ! + ! abstract: calculate w_0,w_d + ! + ! input variables + ! + ! kdt : the number of time step + ! xt : dtl heat content + ! xz : dtl depth + ! xzts : d(zw)/d(ts) + ! xtts : d(xt)/d(ts) + ! + ! output variables + ! + ! w_0 : coefficint 1 to calculate d(tw)/d(ts) + ! w_d : coefficint 2 to calculate d(tw)/d(ts) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xz,xt,xzts,xtts + real(kind=kind_phys), intent(out) :: w_0,w_d + + w_0 = 2.0*(xtts-xt*xzts/xz)/xz + w_d = (2.0*xt*xzts/xz**2-w_0)/xz + + ! if ( 2.0*xt/xz > 1.0 ) then + ! write(*,'(a,i4,2f9.3,4f10.4))') ' cal_w : ',kdt,xz,xt,w_0,w_d,xzts,xtts + ! endif + end subroutine cal_w + + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates the diurnal warming amount at the top layer + !! with thickness of \a delz. + subroutine cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop) + ! + ! abstract: calculate + ! + ! input variables + ! + ! kdt : the number of record + ! timestep : the number of record + ! q_warm : total heat abs in layer dz + ! rho : sea water density + ! dz : dz = max(delz,d_conv) top layer thickness defined to adjust xz + ! xt : heat content in dtl at previous time + ! xz : dtl thickness at previous time + ! + ! output variables + ! + ! ttop : the diurnal warming amount at the top layer with thickness of delz + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,q_warm,rho,dz,xt,xz + real(kind=kind_phys), intent(out) :: ttop + real(kind=kind_phys) :: dt_warm,t0 + + dt_warm = (xt+xt)/xz + t0 = dt_warm*(1.0-dz/(xz+xz)) + ttop = t0 + q_warm*timestep/(rho*cp_w*dz) + + end subroutine cal_ttop + + !>\ingroup gfs_nst_main_mod + !! This subroutine adjust dtm-1p dtl thickness by applying shear flow stability + !! with assumed exponential profile. + subroutine app_sfs(kdt,xt,xs,xu,xv,alpha,beta,grav,d_1p,xz) + ! + ! abstract: adjust dtm-1p dtl thickness by applying shear flow stability with assumed exponetial profile + ! + ! input variables + ! + ! kdt : the number of record + ! xt : heat content in dtl + ! xs : salinity content in dtl + ! xu : u-current content in dtl + ! xv : v-current content in dtl + ! alpha + ! beta + ! grav + ! d_1p : dtl depth before sfs applied + ! + ! output variables + ! + ! xz : dtl depth + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xt,xs,xu,xv,alpha,beta,grav,d_1p + real(kind=kind_phys), intent(out) :: xz + ! real(kind=kind_phys) :: ze,cc,xz0,l,d_sfs, t_sfs, tem + real(kind=kind_phys) :: cc,l,d_sfs,tem + real(kind=kind_phys), parameter :: c2 = 0.3782 + + cc = ri_g/(grav*c2) + + tem = alpha*xt - beta*xs + if (tem > zero) then + d_sfs = sqrt(2.0*cc*(xu*xu+xv*xv)/tem) + else + d_sfs = zero + endif + + ! xz0 = d_1p + ! iter_sfs: do n = 1, niter_sfs + ! l = int_epn(0.0,xz0,0.0,xz0,2) + ! d_sfs = cc*(xu*xu+xv*xv)/((alpha*xt-beta*xs)*l) + ! write(*,'(a,i6,i3,4f9.4))') ' app_sfs_iter : ',kdt,n,cc,l,xz0,d_sfs + ! if ( abs(d_sfs-xz0) < eps_sfs .and. n <= niter_sfs ) exit iter_sfs + ! xz0 = d_sfs + ! enddo iter_sfs + + ! ze = a2*d_sfs ! not used! + + l = int_epn(zero,d_sfs,zero,d_sfs,2) + + ! t_sfs = xt/l + ! xz = (xt+xt) / t_sfs + + xz = l + l + + ! write(*,'(a,i6,6f9.4))') ' app_sfs : ',kdt,xz0,d_sfs,d_1p,xz,2.0*xt/d_1p,t_sfs + end subroutine app_sfs + + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates d(tz)/d(ts). + subroutine cal_tztr(kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr) + ! + ! abstract: calculate d(tz)/d(ts) + ! + ! input variables + ! + ! kdt : the number of record + ! xt : heat content in dtl + ! xz : dtl depth (m) + ! c_0 : coefficint 1 to calculate d(tc)/d(ts) + ! c_d : coefficint 2 to calculate d(tc)/d(ts) + ! w_0 : coefficint 1 to calculate d(tw)/d(ts) + ! w_d : coefficint 2 to calculate d(tw)/d(ts) + ! + ! output variables + ! + ! tztr : d(tz)/d(tr) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xt,c_0,c_d,w_0,w_d,zc,zw,z + real(kind=kind_phys), intent(out) :: tztr + + if ( xt > zero ) then + if ( z <= zc ) then + ! tztr = 1.0/(1.0-w_0+c_0)+z*(w_d-c_d)/(1.0-w_0+c_0) + tztr = (1.0+z*(w_d-c_d))/(1.0-w_0+c_0) + elseif ( z > zc .and. z < zw ) then + ! tztr = (1.0+c_0)/(1.0-w_0+c_0)+z*w_d/(1.0-w_0+c_0) + tztr = (1.0+c_0+z*w_d)/(1.0-w_0+c_0) + elseif ( z >= zw ) then + tztr = 1.0 + endif + elseif ( xt == zero ) then + if ( z <= zc ) then + ! tztr = 1.0/(1.0+c_0)-z*c_d/(1.0+c_0) + tztr = (1.0-z*c_d)/(1.0+c_0) + else + tztr = 1.0 + endif + else + tztr = 1.0 + endif + + ! write(*,'(a,i4,9f9.4))') ' cal_tztr : ',kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr + end subroutine cal_tztr + + !>\ingroup gfs_nst_main_mod + !> This subroutine contains the upper ocean cool-skin parameterization + !! (Fairall et al, 1996 \cite fairall_et_al_1996). + subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le,deltat_c,z_c,c_0,c_d) + ! + ! upper ocean cool-skin parameterizaion, fairall et al, 1996. + ! + ! input: + ! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s) + ! f_nsol : the "nonsolar" part of the surface heat flux (w/m^s) + ! f_sol_0 : solar radiation at the ocean surface (w/m^2) + ! evap : latent heat flux (w/m^2) + ! sss : ocean upper mixed layer salinity (ppu) + ! alpha : thermal expansion coefficient + ! beta : saline contraction coefficient + ! rho_w : oceanic density + ! rho_a : atmospheric density + ! ts : oceanic surface temperature + ! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes + ! hl_ts : d(hl)/d(ts) + ! grav : gravity + ! le : + ! + ! output: + ! deltat_c: cool-skin temperature correction (degrees k) + ! z_c : molecular sublayer (cool-skin) thickness (m) + ! c_0 : coefficient1 to calculate d(tz)/d(ts) + ! c_d : coefficient2 to calculate d(tz)/d(ts) + + ! + real(kind=kind_phys), intent(in) :: ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le + real(kind=kind_phys), intent(out) :: deltat_c,z_c,c_0,c_d + ! declare local variables + real(kind=kind_phys), parameter :: a1=0.065, a2=11.0, a3=6.6e-5, a4=8.0e-4, tcw=0.6, tcwi=1.0/tcw + real(kind=kind_phys) :: a_c,b_c,zc_ts,bc1,bc2 + real(kind=kind_phys) :: xi,hb,ustar1_a,bigc,deltaf,fxp + real(kind=kind_phys) :: zcsq + real(kind=kind_phys) :: cc1,cc2,cc3 + + + z_c = z_c_ini ! initial guess + + ustar1_a = max(ustar_a,ustar_a_min) + + call sw_rad_skin(z_c,fxp) + deltaf = f_sol_0*fxp + + hb = alpha*(f_nsol-deltaf)+beta*sss*cp_w*evap/le + bigc = 16*grav*cp_w*(rho_w*visw)**3/(rho_a*rho_a*kw*kw) + + if ( hb > 0 ) then + xi = 6./(1+(bigc*hb/ustar1_a**4)**0.75)**0.3333333 + else + xi = 6.0 + endif + z_c = min(z_c_max,xi*visw/(sqrt(rho_a/rho_w)*ustar1_a )) + + call sw_rad_skin(z_c,fxp) + + deltaf = f_sol_0*fxp + deltaf = f_nsol - deltaf + if ( deltaf > 0 ) then + deltat_c = deltaf * z_c / kw + else + deltat_c = zero + z_c = zero + endif + ! + ! calculate c_0 & c_d + ! + if ( z_c > zero ) then + cc1 = 6.0*visw / (tcw*ustar1_a*sqrt(rho_a/rho_w)) + cc2 = bigc*alpha / max(ustar_a,ustar_a_min)**4 + cc3 = beta*sss*cp_w/(alpha*le) + zcsq = z_c * z_c + a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4) + + if ( hb > zero .and. zcsq > zero .and. alpha > zero) then + bc1 = zcsq * (q_ts+cc3*hl_ts) + bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq) + zc_ts = bc1/bc2 + ! b_c = z_c**2*(q_ts+cc3*hl_ts)/(z_c**2*f_sol_0*a_c-4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*z_c**2)) ! d(z_c)/d(ts) + b_c = (q_ts+cc3*hl_ts)/(f_sol_0*a_c & + - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq*zcsq)) ! d(z_c)/d(ts) + c_0 = (z_c*q_ts+(f_nsol-deltaf-f_sol_0*a_c*z_c)*b_c)*tcwi + c_d = (f_sol_0*a_c*z_c*b_c-q_ts)*tcwi + + else + b_c = zero + zc_ts = zero + c_0 = z_c*q_ts*tcwi + c_d = -q_ts*tcwi + endif + + ! if ( c_0 < 0.0 ) then + ! write(*,'(a,2f12.6,10f10.6)') ' c_0, c_d = ',c_0,c_d,b_c,zc_ts,hb,bc1,bc2,z_c,cc1,cc2,cc3,z_c**2 + ! endif + + ! c_0 = z_c*q_ts/tcw + ! c_d = -q_ts/tcw + + else + c_0 = zero + c_d = zero + endif ! if ( z_c > 0.0 ) then + + end subroutine cool_skin + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This function calculates a definitive integral of an exponential curve (power of 2). + real function int_epn(z1,z2,zmx,ztr,n) + ! + ! abstract: calculate a definitive integral of an exponetial curve (power of 2) + ! + real(kind_phys) :: z1,z2,zmx,ztr,zi + real(kind_phys) :: fa,fb,fi,int + integer :: m,i,n + + m = nint((z2-z1)/delz) + fa = exp(-exp_const*((z1-zmx)/(ztr-zmx))**n) + fb = exp(-exp_const*((z2-zmx)/(ztr-zmx))**n) + int = zero + do i = 1, m-1 + zi = z1 + delz*float(i) + fi = exp(-exp_const*((zi-zmx)/(ztr-zmx))**n) + int = int + fi + enddo + int_epn = delz*((fa+fb)/2.0 + int) + end function int_epn + + !>\ingroup gfs_nst_main_mod + !! This subroutine resets the value of xt,xs,xu,xv,xz. + subroutine dtl_reset_cv(xt,xs,xu,xv,xz) + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz + xt = zero + xs = zero + xu = zero + xv = zero + xz = z_w_max + end subroutine dtl_reset_cv + + !>\ingroup gfs_nst_main_mod + !! This subroutine resets the value of xt,xs,xu,xv,xz,xtts,xzts. + subroutine dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts + xt = zero + xs = zero + xu = zero + xv = zero + xz = z_w_max + xtts = zero + xzts = zero + end subroutine dtl_reset + +end module nst_module diff --git a/physics/SFC_Layer/UFS/module_nst_parameters.f90 b/physics/SFC_Layer/UFS/module_nst_parameters.f90 new file mode 100644 index 000000000..5308345e2 --- /dev/null +++ b/physics/SFC_Layer/UFS/module_nst_parameters.f90 @@ -0,0 +1,156 @@ +!>\file module_nst_parameters.f90 +!! This file contains constants and paramters used in GFS +!! near surface sea temperature scheme. + +!>\defgroup nst_parameters GFS NSST Parameter Module +!! \ingroup gfs_nst_main_mod +!! This module contains constants and parameters used in GFS +!! near surface sea temperature scheme. +!! history: +!! 20210305: X.Li, reduce z_w_max from 30 m to 20 m +module module_nst_parameters + + use machine, only : kind_phys + ! + ! air constants and coefficients from the atmospehric model + use physcons, only: & + eps => con_eps & !< con_rd/con_rv (nd) + ,cp_a => con_cp & !< spec heat air @p (j/kg/k) + ,epsm1 => con_epsm1 & !< eps - 1 (nd) + ,hvap => con_hvap & !< lat heat h2o cond (j/kg) + ,sigma_r => con_sbc & !< stefan-boltzmann (w/m2/k4) + ,grav => con_g & !< acceleration due to gravity (kg/m/s^2) + ,omega => con_omega & !< ang vel of earth (1/s) + ,rvrdm1 => con_fvirt & !< con_rv/con_rd-1. (nd) + ,rd => con_rd & !< gas constant air (j/kg/k) + ,rocp => con_rocp & !< r/cp + ,pi => con_pi + + implicit none + + private + + public :: sigma_r + public :: zero, one, half + public :: niter_conv, niter_z_w, niter_sfs + public :: z_w_max, z_w_min, z_w_ini, z_c_max, z_c_ini, eps_z_w, eps_conv, eps_sfs + public :: ri_c, ri_g, omg_m, omg_sh, tc_w, visw, cp_w, t0k, ustar_a_min, delz, exp_const + public :: rad2deg, const_rot, tw_max, sst_max, solar_time_6am, tau_min, wd_max + + real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, half = 0.5_kind_phys + ! + ! note: take timestep from here later + integer :: & + niter_conv = 5, & + niter_z_w = 5, & + niter_sfs = 5 + ! + ! general constants + real (kind=kind_phys), parameter :: & + sec_in_day = 86400. & + ,sec_in_hour = 3600. & + ,solar_time_6am = 21600.0 & + ,const_rot = 0.000073 & !< constant to calculate corioli force + ,ri_c = 0.65 & + ,ri_g = 0.25 & + ,eps_z_w = 0.01 & !< criteria to finish iterations for z_w + ,eps_conv = 0.01 & !< criteria to finish iterations for d_conv + ,eps_sfs = 0.01 & !< criteria to finish iterations for d_sfs + ,z_w_max = 20.0 & !< max warm layer thickness + ,z_w_min = 0.2 & !< min warm layer thickness + ,z_w_ini = 0.2 & !< initial warm layer thickness in dtl_onset + ,z_c_max = 0.01 & !< maximum of sub-layer thickness (m) + ,z_c_ini = 0.001 & !< initial value of z_c + ,ustar_a_min = 0.031 & !< minimum of friction wind speed (m/s): 0.031 ~ 1m/s at 10 m hight + ,tau_min = 0.005 & !< minimum of wind stress for dtm + ,exp_const = 9.5 & !< coefficient in exponet profile + ,delz = 0.1 & !< vertical increment for integral calculation (m) + ,von = 0.4 & !< von karman's "constant" + ,t0k = 273.16 & !< celsius to kelvin + ,gray = 0.97 & + ,sst_max = 308.16 & + ,tw_max = 5.0 & + ,wd_max = 2.0 & + ,omg_m = 1.0 & !< trace factor to apply salinity effect + ,omg_rot = 1.0 & !< trace factor to apply rotation effect + ,omg_sh = 1.0 & !< trace factor to apply sensible heat due to rainfall effect + ,visw = 1.e-6 & !< m2/s kinematic viscosity water + ,novalue = 0 & + ,smallnumber = 1.e-6 & + ,timestep_oc = sec_in_day/8. & !< time step in the ocean model (3 hours) + ,radian = 2.*pi/180. & + ,rad2deg = 180./pi & + ,cp_w = 4000. & !< specific heat water (j/kg/k ) + ,rho0_w = 1022.0 & !< density water (kg/m3 ) (or 1024.438) + ,vis_w = 1.e-6 & !< kinematic viscosity water (m2/s ) + ,tc_w = 0.6 & !< thermal conductivity water (w/m/k ) + ,capa_w = 3950.0 & !< heat capacity of sea water ! + ,thref = 1.0e-3 !< reference value of specific volume (m**3/kg) + +!!$!============================================ +!!$ +!!$ ,lvapor=2.453e6 & ! latent heat of vaporization note: make it function of t ????? note the same as hvap +!!$ ,alpha=1 ! thermal expansion coefficient +!!$ ,beta ! saline contraction coefficient +!!$ ,cp=1 !=1 specific heat of sea water +!!$ ,g=1 ! acceleration due to gravity +!!$ ,kw=1 ! thermal conductivity of water +!!$ ,nu=1 !kinematic wiscosity +!!$ ,rho_w=1 !water density +!!$ ,rho_a=1 !air density +!!$ ,l_vapr=2.453e6 +!!$ ,novalue=--1.0e+10 +!!$ +!!$c factors +!!$ beta=1.2 !given as 1.25 in fairall et al.(1996) +!!$ von=0.4 ! von karman's "constant" +!!$c fdg=1.00 ! fairall's lkb rr to von karman adjustment +!!$ fdg=1.00 !based on results from flux workshop august 1995 +!!$ tok=273.16 ! celsius to kelvin +!!$ twopi=3.14159*2. +!!$ +!!$c air constants and coefficients +!!$ rgas=287.1 !j/kg/k gas const. dry air +!!$ xlv=(2.501-0.00237*ts)*1e+6 !j/kg latent heat of vaporization at ts +!!$ cpa=1004.67 !j/kg/k specific heat of dry air (businger 1982) +!!$ cpv=cpa*(1+0.84*q) !moist air - currently not used (businger 1982) +!!$ rhoa=p*100./(rgas*(t+tok)*(1.+.61*q)) !kg/m3 moist air density ( " ) +!!$ visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) !m2/s +!!$ !kinematic viscosity of dry air - andreas (1989) crrel rep. 89-11 +!!$c +!!$c cool skin constants +!!$ al=2.1e-5*(ts+3.2)**0.79 !water thermal expansion coefft. +!!$ be=0.026 !salinity expansion coefft. +!!$ cpw=4000. !j/kg/k specific heat water +!!$ rhow=1022. !kg/m3 density water +!!$ visw=1.e-6 !m2/s kinematic viscosity water +!!$ tcw=0.6 !w/m/k thermal conductivity water +!!$ bigc=16.*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) +!!$ wetc=0.622*xlv*qs/(rgas*(ts+tok)**2) !correction for dq;slope of sat. vap. +!!$ +!!$! +!!$! functions +!!$ +!!$ +!!$ real, parameter :: timestep=86400. !integration time step, second +!!$ +!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 +!!$ real, parameter :: capa =3950.0 !heat capacity of sea water +!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 +!!$ real , parameter :: hslab=50.0 !slab ocean depth +!!$ real , parameter :: bad=-1.0e+10 +!!$ real , parameter :: tmin=2.68e+02 +!!$ real , parameter :: tmax=3.11e+02 +!!$ +!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 +!!$ real, parameter :: capa =3950.0 !heat capacity of sea water +!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 +!!$ real, parameter :: tmin=2.68e+02 !normal minimal temp +!!$ real, parameter :: tmax=3.11e+02 !normal max temp +!!$ real, parameter :: smin=1.0 !normal minimal salt +!!$ real, parameter :: smax=50. !normal maximum salt +!!$ real, parameter :: visct=1.e-5 !viscocity for temperature diffusion +!!$ real, parameter :: viscs=1.e-5 !viscocity for salt diffusion +!!$ +!!$ +end module module_nst_parameters diff --git a/physics/SFC_Layer/UFS/module_nst_water_prop.f90 b/physics/SFC_Layer/UFS/module_nst_water_prop.f90 new file mode 100644 index 000000000..858659e90 --- /dev/null +++ b/physics/SFC_Layer/UFS/module_nst_water_prop.f90 @@ -0,0 +1,734 @@ + +!>\file module_nst_water_prop.f90 +!! This file contains GFS NSST water property subroutines. + +!>\defgroup waterprop GFS NSST Water Property +!!This module contains GFS NSST water property subroutines. +!!\ingroup gfs_nst_main_mod +module module_nst_water_prop + use machine , only : kind_phys + use module_nst_parameters , only : t0k, zero, one, half + + implicit none + ! + private + public :: rhocoef, density, sw_rad_skin, grv, sw_ps_9b, sw_ps_9b_aw, get_dtzm_point, get_dtzm_2d + + ! + interface sw_ps_9b + module procedure sw_ps_9b + end interface sw_ps_9b + interface sw_ps_9b_aw + module procedure sw_ps_9b_aw + end interface sw_ps_9b_aw + ! + interface sw_rad + module procedure sw_fairall_6exp_v1 ! sw_wick_v1 + end interface sw_rad + interface sw_rad_aw + module procedure sw_fairall_6exp_v1_aw + end interface sw_rad_aw + interface sw_rad_sum + module procedure sw_fairall_6exp_v1_sum + end interface sw_rad_sum + interface sw_rad_upper + module procedure sw_soloviev_3exp_v2 + end interface sw_rad_upper + interface sw_rad_upper_aw + module procedure sw_soloviev_3exp_v2_aw + end interface sw_rad_upper_aw + interface sw_rad_skin + module procedure sw_ohlmann_v1 + end interface sw_rad_skin +contains + ! ------------------------------------------------------ + !>\ingroup gfs_nst_main_mod + !! This subroutine computes thermal expansion coefficient (alpha) + !! and saline contraction coefficient (beta). + subroutine rhocoef(t, s, rhoref, alpha, beta) + ! ------------------------------------------------------ + + ! compute thermal expansion coefficient (alpha) + ! and saline contraction coefficient (beta) using + ! the international equation of state of sea water + ! (1980). ref: pond and pickard, introduction to + ! dynamical oceanography, pp310. + ! note: compression effects are not included + + real(kind=kind_phys), intent(in) :: t, s, rhoref + real(kind=kind_phys), intent(out) :: alpha, beta + real(kind=kind_phys) :: tc + + tc = t - t0k + + alpha = & + 6.793952e-2 & + - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & + - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & + - 4.0899e-3 * s & + + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & + + 4.0 * 5.3875e-9 * tc**3 * s & + + 1.0227e-4 * s**1.5 - 2.0 * 1.6546e-6 * tc * s**1.5 + + ! note: rhoref - specify + ! + alpha = -alpha/rhoref + + beta = & + 8.24493e-1 - 4.0899e-3 * tc & + + 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 & + + 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 & + + 1.5 * 1.0227e-4 * tc * s**.5 & + - 1.5 * 1.6546e-6 * tc**2 * s**.5 & + + 2.0 * 4.8314e-4 * s + + beta = beta / rhoref + + end subroutine rhocoef + ! ---------------------------------------- + !>\ingroup gfs_nst_main_mod + !! This subroutine computes sea water density. + subroutine density(t, s, rho) + ! ---------------------------------------- + + ! input + real(kind=kind_phys), intent(in) :: t !unit, k + real(kind=kind_phys), intent(in) :: s !unit, 1/1000 + ! output + real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 + ! local + real(kind=kind_phys) :: tc + + ! compute density using the international equation + ! of state of sea water 1980, (pond and pickard, + ! introduction to dynamical oceanography, pp310). + ! compression effects are not included + + rho = zero + tc = t - t0k + + ! effect of temperature on density (lines 1-3) + ! effect of temperature and salinity on density (lines 4-8) + rho = & + 999.842594 + 6.793952e-2 * tc & + - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & + - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & + + 8.24493e-1 * s - 4.0899e-3 * tc * s & + + 7.6438e-5 * tc**2 * s - 8.2467e-7 * tc**3 * s & + + 5.3875e-9 * tc**4 * s - 5.72466e-3 * s**1.5 & + + 1.0227e-4 * tc * s**1.5 - 1.6546e-6 * tc**2 * s**1.5 & + + 4.8314e-4 * s**2 + + end subroutine density + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine computes the fraction of the solar radiation absorbed + !! by the depth z following Paulson and Simpson (1981) \cite paulson_and_simpson_1981 . + elemental subroutine sw_ps_9b(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: fxp + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + ! + if(z>zero) then + fxp=one-(f(1)*exp(-z/gamma(1))+f(2)*exp(-z/gamma(2))+f(3)*exp(-z/gamma(3))+ & + f(4)*exp(-z/gamma(4))+f(5)*exp(-z/gamma(5))+f(6)*exp(-z/gamma(6))+ & + f(7)*exp(-z/gamma(7))+f(8)*exp(-z/gamma(8))+f(9)*exp(-z/gamma(9))) + else + fxp=zero + endif + ! + end subroutine sw_ps_9b + ! + !====================== + ! + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine + elemental subroutine sw_ps_9b_aw(z,aw) + ! + ! d(fw)/d(z) for 9-band + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: aw + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + ! + if(z>zero) then + aw=(f(1)/gamma(1))*exp(-z/gamma(1))+(f(2)/gamma(2))*exp(-z/gamma(2))+(f(3)/gamma(3))*exp(-z/gamma(3))+ & + (f(1)/gamma(4))*exp(-z/gamma(4))+(f(2)/gamma(5))*exp(-z/gamma(5))+(f(6)/gamma(6))*exp(-z/gamma(6))+ & + (f(1)/gamma(7))*exp(-z/gamma(7))+(f(2)/gamma(8))*exp(-z/gamma(8))+(f(9)/gamma(9))*exp(-z/gamma(9)) + else + aw=zero + endif + ! + end subroutine sw_ps_9b_aw + ! + !====================== + !>\ingroup gfs_nst_main_mod + !! This subroutine computes fraction of the solar radiation absorbed by the ocean at the depth + !! z (Fairall et al. (1996) \cite fairall_et_al_1996, p. 1298) following Paulson and Simpson + !! (1981) \cite paulson_and_simpson_1981 . + elemental subroutine sw_fairall_6exp_v1(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: fxp + + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys), dimension(9) :: zgamma + real(kind=kind_phys), dimension(9) :: f_c + ! + if(z>zero) then + zgamma=z/gamma + f_c=f*(one-one/zgamma*(one-exp(-zgamma))) + fxp=sum(f_c) + else + fxp=zero + endif + ! + end subroutine sw_fairall_6exp_v1 + ! + !====================== + ! + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine calculates fraction of the solar radiation absorbed by the + !! ocean at the depth z (fairall et al.(1996) \cite fairall_et_al_1996; p.1298) + !! following Paulson and Simpson (1981) \cite paulson_and_simpson_1981. + elemental subroutine sw_fairall_6exp_v1_aw(z,aw) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! aw: d(fxp)/d(z) + ! + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: aw + + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys), dimension(9) :: zgamma + real(kind=kind_phys), dimension(9) :: f_aw + ! + if(z>zero) then + zgamma=z/gamma + f_aw=(f/z)*((gamma/z)*(one-exp(-zgamma))-exp(-zgamma)) + aw=sum(f_aw) + ! write(*,'(a,f6.2,f12.6,9f10.4)') 'z,aw in sw_rad_aw : ',z,aw,f_aw + else + aw=zero + endif + ! + end subroutine sw_fairall_6exp_v1_aw + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine computes fraction of the solar radiation absorbed by the ocean at the + !! depth z (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1298) following Paulson and + !! Simpson (1981) \cite paulson_and_simpson_1981 . + !>\param[in] z depth (m) + !>\param[out] sum for convection depth calculation + elemental subroutine sw_fairall_6exp_v1_sum(z,sum) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! sum: for convection depth calculation + ! + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: sum + + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys), dimension(9) :: zgamma + real(kind=kind_phys), dimension(9) :: f_sum + ! + ! zgamma=z/gamma + ! f_sum=(zgamma/z)*exp(-zgamma) + ! sum=sum(f_sum) + + sum=( one/gamma(1))*exp(-z/gamma(1))+(one/gamma(2))*exp(-z/gamma(2))+(one/gamma(3))*exp(-z/gamma(3))+ & + (one/gamma(4))*exp(-z/gamma(4))+(one/gamma(5))*exp(-z/gamma(5))+(one/gamma(6))*exp(-z/gamma(6))+ & + (one/gamma(7))*exp(-z/gamma(7))+(one/gamma(8))*exp(-z/gamma(8))+(one/gamma(9))*exp(-z/gamma(9)) + ! + end subroutine sw_fairall_6exp_v1_sum + ! + !====================== + !>\ingroup gfs_nst_main_mod + !! Solar radiation absorbed by the ocean at the depth z (Fairall et al. (1996) + !! \cite fairall_et_al_1996, p.1298) + !!\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) + !!\param[in] z depth (m) + !!\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) + elemental subroutine sw_fairall_simple_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + ! + if(z>zero) then + df_sol_z=f_sol_0*(0.137+11.0*z-6.6e-6/z*(one-exp(-z/8.e-4))) + else + df_sol_z=zero + endif + ! + end subroutine sw_fairall_simple_v1 + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! solar radiation absorbed by the ocean at the depth z (Zeng and Beljaars (2005) + !! \cite zeng_and_beljaars_2005 , p.5). + !>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) + !>\param[in] z depth (m) + !>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) + elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5) + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + ! + if(z>zero) then + df_sol_z=f_sol_0*(0.065+11.0*z-6.6e-5/z*(one-exp(-z/8.e-4))) + else + df_sol_z=zero + endif + ! + end subroutine sw_wick_v1 + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + !! This subroutine computes solar radiation absorbed by the ocean at the depth z + !! (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1301) following + !! Soloviev and Vershinsky (1982) \cite soloviev_and_vershinsky_1982. + !>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) + !>\param[in] z depth (m) + !>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) + elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) + ! following soloviev, 1982 + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + real(kind=kind_phys), dimension(3) :: f_c + real(kind=kind_phys), dimension(3), parameter :: f=(/0.45,0.27,0.28/) + real(kind=kind_phys), dimension(3), parameter :: gamma=(/12.82,0.357,0.014/) + ! + if(z>zero) then + f_c = f*gamma(int(one-exp(-z/gamma))) + df_sol_z = f_sol_0*(one-sum(f_c)/z) + else + df_sol_z = zero + endif + ! + end subroutine sw_soloviev_3exp_v1 + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) + ! following soloviev, 1982 + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z,f_sol_0 + real(kind=kind_phys), intent(out) :: df_sol_z + ! + if(z>zero) then + df_sol_z=f_sol_0*(one & + -(0.28*0.014*(one-exp(-z/0.014)) & + + 0.27*0.357*(one-exp(-z/0.357)) & + + 0.45*12.82*(one-exp(-z/12.82)))/z & + ) + else + df_sol_z=zero + endif + ! + end subroutine sw_soloviev_3exp_v2 + + !>\ingroup gfs_nst_main_mod + elemental subroutine sw_soloviev_3exp_v2_aw(z,aw) + ! + ! aw = d(fxp)/d(z) + ! following soloviev, 1982 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! aw: d(fxp)/d(z) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: aw + real(kind=kind_phys) :: fxp + ! + if(z>zero) then + fxp=(one & + -(0.28*0.014*(one-exp(-z/0.014)) & + + 0.27*0.357*(one-exp(-z/0.357)) & + + 0.45*12.82*(one-exp(-z/12.82)))/z & + ) + aw=one-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82)) + else + aw=zero + endif + end subroutine sw_soloviev_3exp_v2_aw + ! + ! + !====================== + ! + !>\ingroup gfs_nst_main_mod + elemental subroutine sw_ohlmann_v1(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + real(kind=kind_phys), intent(in) :: z + real(kind=kind_phys), intent(out) :: fxp + ! + if(z>zero) then + fxp=.065+11.*z-6.6e-5/z*(one-exp(-z/8.0e-4)) + else + fxp=zero + endif + ! + end subroutine sw_ohlmann_v1 + ! + + !>\ingroup gfs_nst_main_mod + real(kind_phys) function grv(x) + real(kind=kind_phys) :: x !< sin(lat) + real(kind=kind_phys) :: gamma,c1,c2,c3,c4 + gamma=9.7803267715 + c1=0.0052790414 + c2=0.0000232718 + c3=0.0000001262 + c4=0.0000000007 + + grv=gamma*(one+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) + end function grv + + !>\ingroup gfs_nst_main_mod + !>This subroutine computes solar time from the julian date. + subroutine solar_time_from_julian(jday,xlon,soltim) + ! + ! calculate solar time from the julian date + ! + real(kind=kind_phys), intent(in) :: jday + real(kind=kind_phys), intent(in) :: xlon + real(kind=kind_phys), intent(out) :: soltim + real(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime + ! + fjd=jday-floor(jday) + fjd=jday + xhr=floor(fjd*24.0)-sign(12.0,fjd-half) + xmin=nint(fjd*1440.0)-(xhr+sign(12.0,fjd-half))*60.0 + xsec=zero + intime=xhr+xmin/60.0+xsec/3600.0+24.0 + soltim=mod(xlon/15.0+intime,24.0)*3600.0 + end subroutine solar_time_from_julian + + ! + !*********************************************************************** + ! + !>\ingroup gfs_nst_main_mod + !> This subroutine computes julian day and fraction from year, + !! month, day and time UTC. + subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) + !fpp$ noconcur r + !$$$ subprogram documentation block + ! . . . . + ! subprogram: compjd computes julian day and fraction + ! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07 + ! + ! abstract: computes julian day and fraction + ! from year, month, day and time utc. + ! + ! program history log: + ! 77-05-06 ray orzol,gfdl + ! 98-05-15 iredell y2k compliance + ! + ! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) + ! input argument list: + ! jyr - year (4 digits) + ! jmnth - month + ! jday - day + ! jhr - hour + ! jmn - minutes + ! output argument list: + ! jd - julian day. + ! fjd - fraction of the julian day. + ! + ! subprograms called: + ! iw3jdn compute julian day number + ! + ! attributes: + ! language: fortran. + ! + !$$$ + ! + integer :: jyr,jmnth,jday,jhr,jmn,jd + integer :: iw3jdn + real (kind=kind_phys) fjd + jd=iw3jdn(jyr,jmnth,jday) + if(jhr.lt.12) then + jd=jd-1 + fjd=half+jhr/24.+jmn/1440. + else + fjd=(jhr-12)/24.+jmn/1440. + endif + end subroutine compjd + + !>\ingroup gfs_nst_main_mod + !>This subroutine computes dtm (the mean of \f$dT(z)\f$). + subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) + ! ===================================================================== ! + ! ! + ! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! + ! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! + ! ! + ! usage: ! + ! ! + ! call get_dtm12 ! + ! ! + ! inputs: ! + ! (xt,xz,dt_cool,zc,z1,z2, ! + ! outputs: ! + ! dtm) ! + ! ! + ! program history log: ! + ! ! + ! 2015 -- xu li createad original code ! + ! inputs: ! + ! xt - real, heat content in dtl 1 ! + ! xz - real, dtl thickness 1 ! + ! dt_cool - real, sub-layer cooling amount 1 ! + ! zc - sub-layer cooling thickness 1 ! + ! z1 - lower bound of depth of sea temperature 1 ! + ! z2 - upper bound of depth of sea temperature 1 ! + ! outputs: ! + ! dtm - mean of dT(z) (z1 to z2) 1 ! + ! + real (kind=kind_phys), intent(in) :: xt,xz,dt_cool,zc,z1,z2 + real (kind=kind_phys), intent(out) :: dtm + ! Local variables + real (kind=kind_phys) :: dt_warm,dtw,dtc + + ! + ! get the mean warming in the range of z=z1 to z=z2 + ! + dtw = zero + if ( xt > zero ) then + dt_warm = (xt+xt)/xz ! Tw(0) + if ( z1 < z2) then + if ( z2 < xz ) then + dtw = dt_warm*(one-(z1+z2)/(xz+xz)) + elseif ( z1 < xz .and. z2 >= xz ) then + dtw = half*(one-z1/xz)*dt_warm*(xz-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < xz ) then + dtw = dt_warm*(one-z1/xz) + endif + endif + endif + ! + ! get the mean cooling in the range of z=z1 to z=z2 + ! + dtc = zero + if ( zc > zero ) then + if ( z1 < z2) then + if ( z2 < zc ) then + dtc = dt_cool*(one-(z1+z2)/(zc+zc)) + elseif ( z1 < zc .and. z2 >= zc ) then + dtc = half*(one-z1/zc)*dt_cool*(zc-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < zc ) then + dtc = dt_cool*(one-z1/zc) + endif + endif + endif + + ! + ! get the mean T departure from Tf in the range of z=z1 to z=z2 + ! + dtm = dtw - dtc + + end subroutine get_dtzm_point + + !>\ingroup gfs_nst_main_mod + subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm) + !subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) + ! ===================================================================== ! + ! ! + ! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! + ! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! + ! ! + ! usage: ! + ! ! + ! call get_dtzm_2d ! + ! ! + ! inputs: ! + ! (xt,xz,dt_cool,zc,z1,z2, ! + ! outputs: ! + ! dtm) ! + ! ! + ! program history log: ! + ! ! + ! 2015 -- xu li createad original code ! + ! inputs: ! + ! xt - real, heat content in dtl 1 ! + ! xz - real, dtl thickness 1 ! + ! dt_cool - real, sub-layer cooling amount 1 ! + ! zc - sub-layer cooling thickness 1 ! + ! wet - logical, flag for wet point (ocean or lake) 1 ! + ! icy - logical, flag for ice point (ocean or lake) 1 ! + ! nx - integer, dimension in x-direction (zonal) 1 ! + ! ny - integer, dimension in y-direction (meridional) 1 ! + ! z1 - lower bound of depth of sea temperature 1 ! + ! z2 - upper bound of depth of sea temperature 1 ! + ! nth - integer, num of openmp thread 1 ! + ! outputs: ! + ! dtm - mean of dT(z) (z1 to z2) 1 ! + ! + integer, intent(in) :: nx,ny, nth + real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc + logical, dimension(nx,ny), intent(in) :: wet + ! logical, dimension(nx,ny), intent(in) :: wet,icy + real (kind=kind_phys), intent(in) :: z1,z2 + real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm + ! Local variables + integer :: i,j + real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi + + + !$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi) + do j = 1, ny + do i= 1, nx + + dtm(i,j) = zero ! initialize dtm + + if ( wet(i,j) ) then + ! + ! get the mean warming in the range of z=z1 to z=z2 + ! + dtw = zero + if ( xt(i,j) > zero ) then + xzi = one / xz(i,j) + dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0) + if (z1 < z2) then + if ( z2 < xz(i,j) ) then + dtw = dt_warm * (one-half*(z1+z2)*xzi) + elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then + dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1) + endif + elseif (z1 == z2 ) then + if (z1 < xz(i,j) ) then + dtw = dt_warm * (one-z1*xzi) + endif + endif + endif + ! + ! get the mean cooling in the range of z=0 to z=zsea + ! + dtc = zero + if ( zc(i,j) > zero ) then + if ( z1 < z2) then + if ( z2 < zc(i,j) ) then + dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j))) + elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then + dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < zc(i,j) ) then + dtc = dt_cool(i,j) * (one-z1/zc(i,j)) + endif + endif + endif + ! get the mean T departure from Tf in the range of z=z1 to z=z2 + dtm(i,j) = dtw - dtc + endif ! if ( wet(i,j)) then + enddo + enddo + ! + + end subroutine get_dtzm_2d + +end module module_nst_water_prop diff --git a/physics/sfc_diag.f b/physics/SFC_Layer/UFS/sfc_diag.f similarity index 100% rename from physics/sfc_diag.f rename to physics/SFC_Layer/UFS/sfc_diag.f diff --git a/physics/sfc_diag.meta b/physics/SFC_Layer/UFS/sfc_diag.meta similarity index 98% rename from physics/sfc_diag.meta rename to physics/SFC_Layer/UFS/sfc_diag.meta index a16290b58..f4f83ab04 100644 --- a/physics/sfc_diag.meta +++ b/physics/SFC_Layer/UFS/sfc_diag.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_diag type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../ + dependencies = tools/funcphys.f90,hooks/machine.F,hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_diag_post.F90 b/physics/SFC_Layer/UFS/sfc_diag_post.F90 similarity index 100% rename from physics/sfc_diag_post.F90 rename to physics/SFC_Layer/UFS/sfc_diag_post.F90 diff --git a/physics/sfc_diag_post.meta b/physics/SFC_Layer/UFS/sfc_diag_post.meta similarity index 98% rename from physics/sfc_diag_post.meta rename to physics/SFC_Layer/UFS/sfc_diag_post.meta index 17648753a..4abb3bac0 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/SFC_Layer/UFS/sfc_diag_post.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_diag_post type = scheme - dependencies = machine.F + relative_path = ../../ + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_diff.f b/physics/SFC_Layer/UFS/sfc_diff.f similarity index 96% rename from physics/sfc_diff.f rename to physics/SFC_Layer/UFS/sfc_diff.f index 6e834537a..5dd6525f9 100644 --- a/physics/sfc_diff.f +++ b/physics/SFC_Layer/UFS/sfc_diff.f @@ -60,6 +60,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) + & flag_lakefreeze, & !intent(in) & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) & wet,dry,icy, & !intent(in) & thsfc_loc, & !intent(in) @@ -90,6 +91,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) logical, dimension(:), intent(in) :: flag_iter, dry, icy + logical, dimension(:), intent(in) :: flag_lakefreeze logical, dimension(:), intent(inout) :: wet logical, intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation @@ -168,7 +170,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type do i=1,im - if(flag_iter(i)) then + if(flag_iter(i) .or. flag_lakefreeze(i)) then ! Need to initialize ztmax arrays ztmax_lnd(i) = 1. ! log(1) = 0 @@ -348,12 +350,24 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) tvs = half * (tsurf_wat(i)+tskin_wat(i))/prsik1(i) & * virtfac endif - - z0 = 0.01_kp * z0rl_wat(i) - z0max = max(zmin, min(z0,z1(i))) -! ustar_wat(i) = sqrt(grav * z0 / charnock) +! wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) +! + if (sfc_z0_type == -1) then ! using wave model derived momentum roughness + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + 0.01_kp * z0rl_wav(i) + if (redrag) then + z0max = max(min(z0, z0s_max),1.0e-7_kp) + else + z0max = max(min(z0,0.1_kp), 1.0e-7_kp) + endif + z0rl_wat(i) = 100.0_kp * z0max ! cm + else + z0 = 0.01_kp * z0rl_wat(i) + z0max = max(zmin, min(z0,z1(i))) + endif +! !** test xubin's new z0 ! ztmax = z0max @@ -423,17 +437,18 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0rl_wat(i) = 1.0e-4_kp endif - elseif (z0rl_wav(i) <= 1.0e-7_kp .or. & - & z0rl_wav(i) > 1.0_kp) then -! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) - tem1 = 0.11 * vis / ustar_wat(i) - z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) + elseif (z0rl_wav(i) <= 1.0e-7_kp .or. + & z0rl_wav(i) > 1.0_kp) then +! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) + + if (redrag) then + z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) + else + z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) + endif - if (redrag) then - z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) - else - z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) - endif endif endif ! end of if(open ocean) diff --git a/physics/sfc_diff.meta b/physics/SFC_Layer/UFS/sfc_diff.meta similarity index 98% rename from physics/sfc_diff.meta rename to physics/SFC_Layer/UFS/sfc_diff.meta index eb30b8c50..8ca5b24e1 100644 --- a/physics/sfc_diff.meta +++ b/physics/SFC_Layer/UFS/sfc_diff.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_diff type = scheme - dependencies = machine.F + relative_path = ../../ + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -194,6 +195,13 @@ dimensions = () type = logical intent = in +[flag_lakefreeze] + standard_name = flag_for_lake_water_freeze + long_name = flag for lake water freeze + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in [u10m] standard_name = x_wind_at_10m long_name = 10 meter u wind speed diff --git a/physics/SFC_Layer/UFS/sfc_nst.f90 b/physics/SFC_Layer/UFS/sfc_nst.f90 new file mode 100644 index 000000000..08b1b48e4 --- /dev/null +++ b/physics/SFC_Layer/UFS/sfc_nst.f90 @@ -0,0 +1,664 @@ +!>\file sfc_nst.f90 +!! This file contains the GFS NSST model. + +!> This module contains the CCPP-compliant GFS near-surface sea temperature scheme. +module sfc_nst + + use machine , only : kind_phys, kp => kind_phys + use funcphys , only : fpvs + use module_nst_parameters , only : one, zero, half + use module_nst_parameters , only : t0k, cp_w, omg_m, omg_sh, sigma_r, solar_time_6am, sst_max + use module_nst_parameters , only : ri_c, z_w_max, delz, wd_max, rad2deg, const_rot, tau_min, tw_max + use module_nst_water_prop , only : get_dtzm_point, density, rhocoef, grv, sw_ps_9b + use nst_module , only : cool_skin, dtm_1p, cal_w, cal_ttop, convdepth, dtm_1p_fca + use nst_module , only : dtm_1p_tla, dtm_1p_mwa, dtm_1p_mda, dtm_1p_mta, dtl_reset + ! + implicit none +contains + + !>\defgroup gfs_nst_main_mod GFS Near-Surface Sea Temperature Module + !! This module contains the CCPP-compliant GFS near-surface sea temperature scheme. + !> @{ + !! This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile. + !! \section arg_table_sfc_nst_run Argument Table + !! \htmlinclude sfc_nst_run.html + !! + !> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm + subroutine sfc_nst_run & + ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: + pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & + lseaspray, fm, fm10, & + prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & + sinlat, stress, & + sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & + wind, flag_iter, flag_guess, nstf_name1, nstf_name4, & + nstf_name5, lprnt, ipr, thsfc_loc, & + tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & ! --- input/output: + z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, & + qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & ! --- outputs: + ) + ! + ! ===================================================================== ! + ! description: ! + ! ! + ! ! + ! usage: ! + ! ! + ! call sfc_nst ! + ! inputs: ! + ! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! + ! lseaspray, fm, fm10, ! + ! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! + ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! + ! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! + ! nstf_name5, lprnt, ipr, thsfc_loc, ! + ! input/outputs: ! + ! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, ! + ! z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, ! + ! -- outputs: + ! qsurf, gflux, cmm, chh, evap, hflx, ep ! + ! ) + ! ! + ! ! + ! subprogram/functions called: fpvs, density, rhocoef, cool_skin ! + ! ! + ! program history log: ! + ! 2007 -- xu li createad original code ! + ! 2008 -- s. moorthi adapted to the parallel version ! + ! may 2009 -- y.-t. hou modified to include input lw surface ! + ! emissivity from radiation. also replaced the ! + ! often comfusing combined sw and lw suface ! + ! flux with separate sfc net sw flux (defined ! + ! as dn-up) and lw flux. added a program doc block. ! + ! sep 2009 -- s. moorthi removed rcl and additional reformatting ! + ! and optimization + made pa as input pressure unit.! + ! 2009 -- xu li recreatead the code ! + ! feb 2010 -- s. moorthi added some changes made to the previous ! + ! version ! + ! Jul 2016 -- X. Li, modify the diurnal warming event reset ! + ! ! + ! ! + ! ==================== definition of variables ==================== ! + ! ! + ! inputs: size ! + ! im - integer, horiz dimension 1 ! + ! ps - real, surface pressure (pa) im ! + ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! + ! t1 - real, surface layer mean temperature ( k ) im ! + ! q1 - real, surface layer mean specific humidity im ! + ! tref - real, reference/foundation temperature ( k ) im ! + ! cm - real, surface exchange coeff for momentum (m/s) im ! + ! ch - real, surface exchange coeff heat & moisture(m/s) im ! + ! lseaspray- logical, .t. for parameterization for sea spray 1 ! + ! fm - real, a stability profile function for momentum im ! + ! fm10 - real, a stability profile function for momentum im ! + ! at 10m ! + ! prsl1 - real, surface layer mean pressure (pa) im ! + ! prslki - real, im ! + ! prsik1 - real, im ! + ! prslk1 - real, im ! + ! wet - logical, =T if any ocn/lake water (F otherwise) im ! + ! use_lake_model- logical, =T if flake model is used for lake im ! + ! icy - logical, =T if any ice im ! + ! xlon - real, longitude (radians) im ! + ! sinlat - real, sin of latitude im ! + ! stress - real, wind stress (n/m**2) im ! + ! sfcemis - real, sfc lw emissivity (fraction) im ! + ! dlwflx - real, total sky sfc downward lw flux (w/m**2) im ! + ! sfcnsw - real, total sky sfc netsw flx into ocean (w/m**2) im ! + ! rain - real, rainfall rate (kg/m**2/s) im ! + ! timestep - real, timestep interval (second) 1 ! + ! kdt - integer, time step counter 1 ! + ! solhr - real, fcst hour at the end of prev time step 1 ! + ! xcosz - real, consine of solar zenith angle 1 ! + ! wind - real, wind speed (m/s) im ! + ! flag_iter- logical, execution or not im ! + ! when iter = 1, flag_iter = .true. for all grids im ! + ! when iter = 2, flag_iter = .true. when wind < 2 im ! + ! for both land and ocean (when nstf_name1 > 0) im ! + ! flag_guess-logical, .true.= guess step to get CD et al im ! + ! when iter = 1, flag_guess = .true. when wind < 2 im ! + ! when iter = 2, flag_guess = .false. for all grids im ! + ! nstf_name - integers , NSST related flag parameters 1 ! + ! nstf_name1 : 0 = NSSTM off 1 ! + ! 1 = NSSTM on but uncoupled 1 ! + ! 2 = NSSTM on and coupled 1 ! + ! nstf_name4 : zsea1 in mm 1 ! + ! nstf_name5 : zsea2 in mm 1 ! + ! lprnt - logical, control flag for check print out 1 ! + ! ipr - integer, grid index for check print out 1 ! + ! thsfc_loc- logical, flag for reference pressure in theta 1 ! + ! ! + ! input/outputs: + ! li added for oceanic components + ! tskin - real, ocean surface skin temperature ( k ) im ! + ! tsurf - real, the same as tskin ( k ) but for guess run im ! + ! xt - real, heat content in dtl im ! + ! xs - real, salinity content in dtl im ! + ! xu - real, u-current content in dtl im ! + ! xv - real, v-current content in dtl im ! + ! xz - real, dtl thickness im ! + ! zm - real, mxl thickness im ! + ! xtts - real, d(xt)/d(ts) im ! + ! xzts - real, d(xz)/d(ts) im ! + ! dt_cool - real, sub-layer cooling amount im ! + ! d_conv - real, thickness of free convection layer (fcl) im ! + ! z_c - sub-layer cooling thickness im ! + ! c_0 - coefficient1 to calculate d(tz)/d(ts) im ! + ! c_d - coefficient2 to calculate d(tz)/d(ts) im ! + ! w_0 - coefficient3 to calculate d(tz)/d(ts) im ! + ! w_d - coefficient4 to calculate d(tz)/d(ts) im ! + ! ifd - real, index to start dtlm run or not im ! + ! qrain - real, sensible heat flux due to rainfall (watts) im ! + + ! outputs: ! + + ! qsurf - real, surface air saturation specific humidity im ! + ! gflux - real, soil heat flux (w/m**2) im ! + ! cmm - real, im ! + ! chh - real, im ! + ! evap - real, evaperation from latent heat flux im ! + ! hflx - real, sensible heat flux im ! + ! ep - real, potential evaporation im ! + ! ! + ! ===================================================================== ! + + + + ! --- inputs: + integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4, nstf_name5 + real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & + epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice + real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & + t1, q1, tref, cm, ch, fm, fm10, & + prsl1, prslki, prsik1, prslk1, xlon, xcosz, & + sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind + real (kind=kind_phys), intent(in) :: timestep + real (kind=kind_phys), intent(in) :: solhr + + ! For sea spray effect + logical, intent(in) :: lseaspray + ! + logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet + integer, dimension(:), intent(in) :: use_lake_model + logical, intent(in) :: lprnt + logical, intent(in) :: thsfc_loc + + ! --- input/outputs: + ! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation + real (kind=kind_phys), dimension(:), intent(inout) :: tskin, & + tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & + z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain + + ! --- outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: qsurf, gflux, cmm, chh, evap, hflx, ep + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! + ! locals + ! + integer :: k,i + ! + real (kind=kind_phys), dimension(im) :: q0, qss, rch, rho_a, theta1, tv1, wndmag + + real(kind=kind_phys) :: elocp,tem,cpinv,hvapi + ! + ! nstm related prognostic fields + ! + logical :: flag(im) + real (kind=kind_phys), dimension(im) :: xt_old, xs_old, xu_old, xv_old, xz_old, & + zm_old,xtts_old, xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old + + real(kind=kind_phys) :: ulwflx(im), nswsfc(im) + ! real(kind=kind_phys) rig(im), + ! & ulwflx(im),dlwflx(im), + ! & slrad(im),nswsfc(im) + real(kind=kind_phys) :: alpha,beta,rho_w,f_nsol,sss,sep, cosa,sina,taux,tauy, & + grav,dz,t0,ttop0,ttop + + real(kind=kind_phys) :: le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich + real(kind=kind_phys) :: rnl_ts,hs_ts,hl_ts,rf_ts,q_ts + real(kind=kind_phys) :: fw,q_warm + real(kind=kind_phys) :: t12,alon,tsea,sstc,dta,dtz + real(kind=kind_phys) :: zsea1,zsea2,soltim + logical :: do_nst + ! + ! parameters for sea spray effect + ! + real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, & + bb1, hflxs, evaps, ptem + ! + ! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, + ! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, + ! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, + real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, & + ws10cr=30., conlf=7.2e-9, consf=6.4e-8 + ! + !====================================================================================================== + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (nstf_name1 == 0) return ! No NSST model used + + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp + + sss = 34.0_kp ! temporarily, when sea surface salinity data is not ready + ! + ! flag for open water and where the iteration is on + ! + do_nst = .false. + do i = 1, im + ! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) + flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1 + do_nst = do_nst .or. flag(i) + enddo + if (.not. do_nst) return + ! + ! save nst-related prognostic fields for guess run + ! + do i=1, im + ! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then + if(wet(i) .and. flag_guess(i) .and. use_lake_model(i)/=1) then + xt_old(i) = xt(i) + xs_old(i) = xs(i) + xu_old(i) = xu(i) + xv_old(i) = xv(i) + xz_old(i) = xz(i) + zm_old(i) = zm(i) + xtts_old(i) = xtts(i) + xzts_old(i) = xzts(i) + ifd_old(i) = ifd(i) + tskin_old(i) = tskin(i) + dt_cool_old(i) = dt_cool(i) + z_c_old(i) = z_c(i) + endif + enddo + + + ! --- ... initialize variables. all units are m.k.s. unless specified. + ! ps is in pascals, wind is wind speed, theta1 is surface air + ! estimated from level 1 temperature, rho_a is air density and + ! qss is saturation specific humidity at the water surface + !! + do i = 1, im + if ( flag(i) ) then + + nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) + wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) + + q0(i) = max(q1(i), 1.0e-8_kp) + + if(thsfc_loc) then ! Use local potential temperature + theta1(i) = t1(i) * prslki(i) + else ! Use potential temperature referenced to 1000 hPa + theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer + endif + + tv1(i) = t1(i) * (one + rvrdm1*q0(i)) + rho_a(i) = prsl1(i) / (rd*tv1(i)) + qss(i) = fpvs(tsurf(i)) ! pa + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa + ! + evap(i) = zero + hflx(i) = zero + gflux(i) = zero + ep(i) = zero + + ! --- ... rcp = rho cp ch v + + rch(i) = rho_a(i) * cp * ch(i) * wind(i) + cmm(i) = cm (i) * wind(i) + chh(i) = rho_a(i) * ch(i) * wind(i) + + !> - Calculate latent and sensible heat flux over open water with tskin. + ! at previous time step + evap(i) = elocp * rch(i) * (qss(i) - q0(i)) + qsurf(i) = qss(i) + + if(thsfc_loc) then ! Use local potential temperature + hflx(i) = rch(i) * (tsurf(i) - theta1(i)) + else ! Use potential temperature referenced to 1000 hPa + hflx(i) = rch(i) * (tsurf(i)/prsik1(i) - theta1(i)) + endif + + ! if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=', + ! & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i) + ! &,' tsurf=',tsurf(i) + endif + enddo + + ! run nst model: dtm + slm + ! + zsea1 = 0.001_kp*real(nstf_name4) + zsea2 = 0.001_kp*real(nstf_name5) + + !> - Call module_nst_water_prop::density() to compute sea water density. + !> - Call module_nst_water_prop::rhocoef() to compute thermal expansion + !! coefficient (\a alpha) and saline contraction coefficient (\a beta). + do i = 1, im + if ( flag(i) ) then + tsea = tsurf(i) + t12 = tsea*tsea + ulwflx(i) = sfcemis(i) * sbc * t12 * t12 + alon = xlon(i)*rad2deg + grav = grv(sinlat(i)) + soltim = mod(alon/15.0_kp + solhr, 24.0_kp)*3600.0_kp + call density(tsea,sss,rho_w) ! sea water density + call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta + ! + !> - Calculate sensible heat flux (\a qrain) due to rainfall. + ! + le = (2.501_kp-0.00237_kp*tsea)*1.0e6_kp + dwat = 2.11e-5_kp*(t1(i)/t0k)**1.94_kp ! water vapor diffusivity + dtmp = (one+3.309e-3_kp*(t1(i)-t0k)-1.44e-6_kp*(t1(i)-t0k) & + * (t1(i)-t0k))*0.02411_kp/(rho_a(i)*cp) ! heat diffusivity + wetc = 622.0_kp*le*qss(i)/(rd*t1(i)*t1(i)) + alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor + tem = (1.0e3_kp * rain(i) / rho_w) * alfac * cp_w + qrain(i) = tem * (tsea-t1(i)+1.0e3_kp*(qss(i)-q0(i))*le/cp) + + !> - Calculate input non solar heat flux as upward = positive to models here + + f_nsol = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i) + omg_sh*qrain(i) + + ! if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=', + ! &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i) + ! &,' omg_sh=',omg_sh,' qrain=',qrain(i) + + sep = sss*(evap(i)/le-rain(i))/rho_w + ustar_a = sqrt(stress(i)/rho_a(i)) ! air friction velocity + ! + ! sensitivities of heat flux components to ts + ! + rnl_ts = 4.0_kp*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) + hs_ts = rch(i) + hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) + rf_ts = tem * (one+rch(i)*hl_ts) + q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts + ! + !> - Call cool_skin(), which is the sub-layer cooling parameterization + !! (Fairfall et al. (1996) \cite fairall_et_al_1996). + ! & calculate c_0, c_d + ! + call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta, & + rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le, & + dt_cool(i),z_c(i),c_0(i),c_d(i)) + + tem = one / wndmag(i) + cosa = u1(i)*tem + sina = v1(i)*tem + taux = max(stress(i),tau_min)*cosa + tauy = max(stress(i),tau_min)*sina + fc = const_rot*sinlat(i) + ! + ! Run DTM-1p system. + ! + if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then + else + ifd(i) = one + ! + ! calculate fcl thickness with current forcing and previous time's profile + ! + ! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i) + + !> - Call convdepth() to calculate depth for convective adjustments. + if ( f_nsol > zero .and. xt(i) > zero ) then + call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w, & + alpha,beta,xt(i),xs(i),xz(i),d_conv(i)) + else + d_conv(i) = zero + endif + + ! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i) + ! + ! determine rich: wind speed dependent (right now) + ! + ! if ( wind(i) < 1.0 ) then + ! rich = 0.25 + 0.03*wind(i) + ! elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then + ! rich = 0.25 + 0.1*wind(i) + ! elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then + ! rich = 0.25 + 0.6*wind(i) + ! elseif ( wind(i) >= 6.0 ) then + ! rich = 0.25 + min(0.8*wind(i),0.50) + ! endif + + rich = ri_c + + !> - Call the diurnal thermocline layer model dtm_1p(). + call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i), & + f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon, & + sinlat(i),soltim,grav,le,d_conv(i), & + xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + + ! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) + + ! apply mda + if ( xt(i) > zero ) then + !> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply + !! minimum depth adjustment (mda). + call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + !> - If \a dtl thickness >= module_nst_parameters::z_w_max, call dtl_reset() + !! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max. + call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i), xzts(i)) + + ! if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max=' + ! &,z_w_max + endif + + ! apply fca + if ( d_conv(i) > zero ) then + !> - If thickness of free convection layer > 0.0, call dtm_1p_fca() + !! to apply free convection adjustment. + !> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset() + !! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max(). + call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + + ! if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i) + + ! apply tla + dz = min(xz(i),max(d_conv(i),delz)) + ! + !> - Call sw_ps_9b() to compute the fraction of the solar radiation + !! absorbed by the depth \a delz (Paulson and Simpson (1981) \cite paulson_and_simpson_1981). + !! And calculate the total heat absorbed in warm layer. + call sw_ps_9b(delz,fw) + q_warm = fw*nswsfc(i)-f_nsol !total heat absorbed in warm layer + + !> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with + !! thickness of \a dz. + if ( q_warm > zero ) then + call cal_ttop(kdt,timestep,q_warm,rho_w,dz, xt(i),xz(i),ttop0) + + ! if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=', + ! &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i), + ! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i), + ! &' xz=',xz(i),' qrain=',qrain(i) + + ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i)))) + + ! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i) + ! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz + ! &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0 + + !> - Call dtm_1p_tla() to apply top layer adjustment. + if ( ttop > ttop0 ) then + call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i)) + + ! if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=', + ! &z_w_max + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + endif ! if ( q_warm > 0.0 ) then + + ! if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i) + + ! apply mwa + !> - Call dt_1p_mwa() to apply maximum warming adjustment. + t0 = (xt(i)+xt(i))/xz(i) + if ( t0 > tw_max ) then + call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + + ! if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i) + + ! apply mta + !> - Call dtm_1p_mta() to apply maximum temperature adjustment. + sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i) + + if ( sstc > sst_max ) then + dta = sstc - sst_max + call dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i)) + ! write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i), + ! & sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i) + if ( xz(i) >= z_w_max ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + ! + endif ! if ( xt(i) > 0.0 ) then + ! reset dtl at midnight and when solar zenith angle > 89.994 degree + if ( abs(soltim) < 2.0_kp*timestep ) then + call dtl_reset (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + + endif ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day + + ! if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i) + + ! update tsurf (when flag(i) .eqv. .true. ) + !> - Call get_dtzm_point() to computes \a dtz and \a tsurf. + call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), zsea1,zsea2,dtz) + tsurf(i) = max(tgice, tref(i) + dtz ) + + ! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=', + ! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i) + + !> - Call cal_w() to calculate \a w_0 and \a w_d. + if ( xt(i) > zero ) then + call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i)) + else + w_0(i) = zero + w_d(i) = zero + endif + + ! if ( xt(i) > 0.0 ) then + ! rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i)) + ! & /(2.0*(xu(i)*xu(i)+xv(i)*xv(i))) + ! else + ! rig(i) = 0.25 + ! endif + + ! qrain(i) = rig(i) + zm(i) = wind(i) + + endif + enddo + + ! restore nst-related prognostic fields for guess run + do i=1, im + ! if (wet(i) .and. .not.icy(i)) then + if (wet(i) .and. use_lake_model(i)/=1) then + if (flag_guess(i)) then ! when it is guess of + xt(i) = xt_old(i) + xs(i) = xs_old(i) + xu(i) = xu_old(i) + xv(i) = xv_old(i) + xz(i) = xz_old(i) + zm(i) = zm_old(i) + xtts(i) = xtts_old(i) + xzts(i) = xzts_old(i) + ifd(i) = ifd_old(i) + tskin(i) = tskin_old(i) + dt_cool(i) = dt_cool_old(i) + z_c(i) = z_c_old(i) + else + ! + ! update tskin when coupled and not guess run + ! (all other NSST variables have been updated in this case) + ! + if ( nstf_name1 > 1 ) then + tskin(i) = tsurf(i) + endif ! if nstf_name1 > 1 then + endif ! if flag_guess(i) then + endif ! if wet(i) .and. .not.icy(i) then + enddo + + ! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i) + + if ( nstf_name1 > 1 ) then + !> - Calculate latent and sensible heat flux over open water with updated tskin + !! for the grids of open water and the iteration is on. + do i = 1, im + if ( flag(i) ) then + qss(i) = fpvs( tskin(i) ) + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) + qsurf(i) = qss(i) + evap(i) = elocp*rch(i) * (qss(i) - q0(i)) + + if(thsfc_loc) then ! Use local potential temperature + hflx(i) = rch(i) * (tskin(i) - theta1(i)) + else ! Use potential temperature referenced to 1000 hPa + hflx(i) = rch(i) * (tskin(i)/prsik1(i) - theta1(i)) + endif + + endif + enddo + endif ! if ( nstf_name1 > 1 ) then + ! + !> - Include sea spray effects + ! + do i=1,im + if(lseaspray .and. flag(i)) then + f10m = fm10(i) / fm(i) + u10m = f10m * u1(i) + v10m = f10m * v1(i) + ws10 = sqrt(u10m*u10m + v10m*v10m) + ws10 = max(ws10,1.) + ws10 = min(ws10,ws10cr) + tem = .015 * ws10 * ws10 + ru10 = 1. - .087 * log(10./tem) + qss1 = fpvs(t1(i)) + qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) + tem = rd * cp * t1(i) * t1(i) + tem = 1. + eps * hvap * hvap * qss1 / tem + bb1 = 1. / tem + evaps = conlf * (ws10**5.4) * ru10 * bb1 + evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i)) + evap(i) = evap(i) + alps * evaps + hflxs = consf * (ws10**3.4) * ru10 + hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i)) + ptem = alps - gams + hflx(i) = hflx(i) + bets * hflxs - ptem * evaps + endif + enddo + ! + do i=1,im + if ( flag(i) ) then + tem = one / rho_a(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo + ! + ! if (lprnt) print *,' tskin=',tskin(ipr) + + return + end subroutine sfc_nst_run + !> @} +end module sfc_nst diff --git a/physics/sfc_nst.meta b/physics/SFC_Layer/UFS/sfc_nst.meta similarity index 99% rename from physics/sfc_nst.meta rename to physics/SFC_Layer/UFS/sfc_nst.meta index dc35ec959..131daaab0 100644 --- a/physics/sfc_nst.meta +++ b/physics/SFC_Layer/UFS/sfc_nst.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sfc_nst type = scheme - dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 + dependencies = date_def.f,../../tools/funcphys.f90,../../hooks/machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/SFC_Layer/UFS/sfc_nst_post.f90 b/physics/SFC_Layer/UFS/sfc_nst_post.f90 new file mode 100644 index 000000000..174d5df76 --- /dev/null +++ b/physics/SFC_Layer/UFS/sfc_nst_post.f90 @@ -0,0 +1,87 @@ +!> \file sfc_nst_post.f90 +!! This file contains code to be executed after the GFS NSST model. + +module sfc_nst_post + + use machine , only : kind_phys, kp => kind_phys + use module_nst_water_prop , only : get_dtzm_2d + + implicit none + +contains + + ! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post + + !> \section arg_table_sfc_nst_post_run Argument Table + !! \htmlinclude sfc_nst_post_run.html + !! + ! \section NSST_general_post_algorithm General Algorithm + ! + ! \section NSST_detailed_post_algorithm Detailed Algorithm + ! @{ + subroutine sfc_nst_post_run & + ( im, kdt, rlapse, tgice, wet, use_lake_model, icy, oro, & + oro_uf, nstf_name1, & + nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & + tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & + ) + ! --- inputs: + integer, intent(in) :: im, kdt, nthreads + logical, dimension(:), intent(in) :: wet, icy + integer, dimension(:), intent(in) :: use_lake_model + real (kind=kind_phys), intent(in) :: rlapse, tgice + real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf + integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 + real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, dt_cool, z_c, tref, xlon + + ! --- input/outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, tsfc_wat + + ! --- outputs: + real (kind=kind_phys), dimension(:), intent(out) :: dtzm + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! --- locals + integer :: i + real(kind=kind_phys) :: zsea1, zsea2 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), + ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), + ! & ' kdt=',kdt + + ! do i = 1, im + ! if (wet(i) .and. .not. icy(i)) then + ! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse + ! endif + ! enddo + + ! --- ... run nsst model ... --- + + if (nstf_name1 > 1) then + zsea1 = 0.001_kp*real(nstf_name4) + zsea2 = 0.001_kp*real(nstf_name5) + call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, im, 1, nthreads, dtzm) + do i = 1, im + ! if (wet(i) .and. .not.icy(i)) then + ! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then + if (wet(i) .and. use_lake_model(i) /=1) then + tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) + ! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & + ! (oro(i)-oro_uf(i))*rlapse + endif + enddo + endif + + ! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & + ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt + + return + end subroutine sfc_nst_post_run + +end module sfc_nst_post diff --git a/physics/sfc_nst_post.meta b/physics/SFC_Layer/UFS/sfc_nst_post.meta similarity index 98% rename from physics/sfc_nst_post.meta rename to physics/SFC_Layer/UFS/sfc_nst_post.meta index 7f66118e9..caa487384 100644 --- a/physics/sfc_nst_post.meta +++ b/physics/SFC_Layer/UFS/sfc_nst_post.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = sfc_nst_post type = scheme - dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + dependencies = ../../hooks/machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/SFC_Layer/UFS/sfc_nst_pre.f90 b/physics/SFC_Layer/UFS/sfc_nst_pre.f90 new file mode 100644 index 000000000..3e77f2d6b --- /dev/null +++ b/physics/SFC_Layer/UFS/sfc_nst_pre.f90 @@ -0,0 +1,89 @@ +!> \file sfc_nst_pre.f90 +!! This file contains preparation for the GFS NSST model. + +module sfc_nst_pre + + use machine , only : kind_phys + use module_nst_water_prop , only : get_dtzm_2d + use module_nst_parameters , only : zero, one + + implicit none + +contains + + !> \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre + !! + !! The NSST scheme is one of the three schemes used to represent the + !! surface in the GFS physics suite. The other two are the Noah land + !! surface model and the sice simplified ice model. + !! + !! \section arg_table_sfc_nst_pre_run Argument Table + !! \htmlinclude sfc_nst_pre_run.html + !! + !> \section NSST_general_pre_algorithm General Algorithm + subroutine sfc_nst_pre_run & + (im, wet, tgice, tsfco, tsurf_wat, & + tseal, xt, xz, dt_cool, z_c, tref, cplflx, & + oceanfrac, nthreads, errmsg, errflg) + + ! --- inputs: + integer, intent(in) :: im, nthreads + logical, dimension(:), intent(in) :: wet + real (kind=kind_phys), intent(in) :: tgice + real (kind=kind_phys), dimension(:), intent(in) :: tsfco, xt, xz, dt_cool, z_c, oceanfrac + logical, intent(in) :: cplflx + + ! --- input/outputs: + real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, tseal, tref + + ! --- outputs: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! --- locals + integer :: i + real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys + real(kind=kind_phys) :: tem2, dnsst + real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + if (wet(i) .and. oceanfrac(i) > 0.0) then + ! tem = (oro(i)-oro_uf(i)) * rlapse + ! DH* 20190927 simplyfing this code because tem is zero + !tem = zero + !tseal(i) = tsfco(i) + tem + tseal(i) = tsfco(i) + !tsurf_wat(i) = tsurf_wat(i) + tem + ! *DH + endif + enddo + ! + ! update tsfc & tref with T1 from OGCM & NSST Profile if coupled + ! + if (cplflx) then + z_c_0 = zero + call get_dtzm_2d (xt, xz, dt_cool, z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) + do i=1,im + if (wet(i) .and. oceanfrac(i) > zero ) then + ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf + tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile + ! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update + ! tseal(i) = tsfc_wat(i) + if (abs(xz(i)) > zero) then + tem2 = one / xz(i) + else + tem2 = zero + endif + tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) + tsurf_wat(i) = tseal(i) + endif + enddo + endif + + return + end subroutine sfc_nst_pre_run +end module sfc_nst_pre diff --git a/physics/sfc_nst_pre.meta b/physics/SFC_Layer/UFS/sfc_nst_pre.meta similarity index 97% rename from physics/sfc_nst_pre.meta rename to physics/SFC_Layer/UFS/sfc_nst_pre.meta index 88788ff5c..e9cdef0d1 100644 --- a/physics/sfc_nst_pre.meta +++ b/physics/SFC_Layer/UFS/sfc_nst_pre.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = sfc_nst_pre type = scheme - dependencies = machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 + dependencies = ../../hooks/machine.F,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/clm_lake.f90 b/physics/SFC_Models/Lake/CLM/clm_lake.f90 similarity index 99% rename from physics/clm_lake.f90 rename to physics/SFC_Models/Lake/CLM/clm_lake.f90 index 620f79a96..91e8c71b7 100644 --- a/physics/clm_lake.f90 +++ b/physics/SFC_Models/Lake/CLM/clm_lake.f90 @@ -238,7 +238,10 @@ subroutine calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake,dz_lake) real(kind_lake) :: dz_lake(nlevlake) ! layer thickness for lake (m) real(kind_lake) :: depthratio - if (input_lakedepth(i) == spval) then + if (input_lakedepth(i) == spval .or. input_lakedepth(i) < 0.1) then + ! This is a safeguard against: + ! 1. missing in the lakedepth database (== spval) + ! 2. errors in model cycling or unexpected changes in the orography database (< 0.1) clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake) z_lake(1:nlevlake) = zlak(1:nlevlake) dz_lake(1:nlevlake) = dzlak(1:nlevlake) @@ -267,8 +270,8 @@ SUBROUTINE clm_lake_run( & ! Atmospheric model state inputs: tg3, pgr, zlvl, gt0, prsi, phii, qvcurr, gu0, gv0, xlat_d, xlon_d, & - ch, cm, dlwsfci, dswsfci, oro_lakedepth, wind, rho0, tsfc, & - flag_iter, ISLTYP, rainncprv, raincprv, & + ch, cm, dlwsfci, dswsfci, oro_lakedepth, wind, tsfc, & + flag_iter, flag_lakefreeze, ISLTYP, rainncprv, raincprv, & ! Feedback to atmosphere: evap_wat, evap_ice, hflx_wat, hflx_ice, gflx_wat, gflx_ice, & @@ -283,7 +286,7 @@ SUBROUTINE clm_lake_run( & salty, savedtke12d, snowdp2d, h2osno2d, snl2d, t_grnd2d, t_lake3d, & lake_icefrac3d, t_soisno3d, h2osoi_ice3d, h2osoi_liq3d, h2osoi_vol3d, & - z3d, dz3d, zi3d, & + z3d, dz3d, zi3d, t1, qv1, prsl1, & input_lakedepth, clm_lakedepth, cannot_freeze, & ! Error reporting: @@ -321,10 +324,12 @@ SUBROUTINE clm_lake_run( & ! REAL(KIND_PHYS), DIMENSION(:), INTENT(IN):: & tg3, pgr, zlvl, qvcurr, xlat_d, xlon_d, ch, cm, & - dlwsfci, dswsfci, oro_lakedepth, wind, rho0, & - rainncprv, raincprv + dlwsfci, dswsfci, oro_lakedepth, wind, & + rainncprv, raincprv, t1, qv1, prsl1 REAL(KIND_PHYS), DIMENSION(:,:), INTENT(in) :: gu0, gv0, prsi, gt0, phii LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter + LOGICAL, DIMENSION(:), INTENT(INOUT) :: flag_lakefreeze + INTEGER, DIMENSION(:), INTENT(IN) :: ISLTYP ! @@ -450,6 +455,7 @@ SUBROUTINE clm_lake_run( & logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE real(kind_lake) :: to_radians, lat_d, lon_d, qss, tkm, bd + real(kind_lake) :: rho0 ! lowest model level air density integer :: month,num1,num2,day_of_month,isl real(kind_lake) :: wght1,wght2,Tclim,depthratio @@ -693,12 +699,13 @@ SUBROUTINE clm_lake_run( & !-- The CLM output is combined for fractional ice and water if( t_grnd(c) >= tfrz ) then - qfx = eflx_lh_tot(c)*invhvap + qfx = eflx_lh_tot(c)*invhvap else - qfx = eflx_lh_tot(c)*invhsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) + qfx = eflx_lh_tot(c)*invhsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) endif - evap_wat(i) = qfx/rho0(i) ! kinematic_surface_upward_latent_heat_flux_over_water - hflx_wat(i)=eflx_sh_tot(c)/(rho0(i)*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water + rho0 = prsl1(i) / (rair*t1(i)*(1.0 + con_fvirt*qv1(i))) + evap_wat(i) = qfx/rho0 ! kinematic_surface_upward_latent_heat_flux_over_water + hflx_wat(i) = eflx_sh_tot(c)/(rho0*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water gflx_wat(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water ep1d_water(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water tsurf_water(I) = t_grnd(c) ![K] surface skin temperature after iteration over water @@ -754,6 +761,11 @@ SUBROUTINE clm_lake_run( & weasd(i) = weasdi(i) snowd(i) = snodi(c) ! surface_snow_thickness_water_equivalent_over_ice + + if (.not. icy(i)) then + flag_lakefreeze(i)=.true. + end if + ! Ice points are icy: icy(i)=.true. ! flag_nonzero_sea_ice_surface_fraction ice_points = ice_points+1 diff --git a/physics/clm_lake.meta b/physics/SFC_Models/Lake/CLM/clm_lake.meta similarity index 97% rename from physics/clm_lake.meta rename to physics/SFC_Models/Lake/CLM/clm_lake.meta index 11a44286a..99c7970d3 100644 --- a/physics/clm_lake.meta +++ b/physics/SFC_Models/Lake/CLM/clm_lake.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = clm_lake type = scheme - dependencies = machine.F + dependencies = ../../../hooks/machine.F ######################################################################## [ccpp-arg-table] @@ -305,14 +305,6 @@ type = real kind = kind_phys intent = in -[rho0] - standard_name = air_pressure_at_surface_adjacent_layer - long_name = mean pressure at lowest model layer - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [tsfc] standard_name = surface_skin_temperature long_name = surface skin temperature @@ -328,6 +320,13 @@ dimensions = (horizontal_loop_extent) type = logical intent = in +[flag_lakefreeze] + standard_name = flag_for_lake_water_freeze + long_name = flag for lake water freeze + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout [isltyp] standard_name = soil_type_classification long_name = soil type at each grid cell @@ -732,6 +731,30 @@ type = real kind = kind_phys intent = in +[t1] + standard_name = air_temperature_at_surface_adjacent_layer + long_name = mean temperature at lowest model layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[qv1] + standard_name = specific_humidity_at_surface_adjacent_layer + long_name = water vapor specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[prsl1] + standard_name = air_pressure_at_surface_adjacent_layer + long_name = mean pressure at lowest model layer + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/flake.F90 b/physics/SFC_Models/Lake/Flake/flake.F90 similarity index 100% rename from physics/flake.F90 rename to physics/SFC_Models/Lake/Flake/flake.F90 diff --git a/physics/flake_driver.F90 b/physics/SFC_Models/Lake/Flake/flake_driver.F90 similarity index 100% rename from physics/flake_driver.F90 rename to physics/SFC_Models/Lake/Flake/flake_driver.F90 diff --git a/physics/flake_driver.meta b/physics/SFC_Models/Lake/Flake/flake_driver.meta similarity index 99% rename from physics/flake_driver.meta rename to physics/SFC_Models/Lake/Flake/flake_driver.meta index e665dc962..22ab62d1e 100644 --- a/physics/flake_driver.meta +++ b/physics/SFC_Models/Lake/Flake/flake_driver.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = flake_driver type = scheme - dependencies = flake.F90,machine.F + dependencies = ../../../hooks/machine.F,flake.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/lsm_noah.f b/physics/SFC_Models/Land/Noah/lsm_noah.f similarity index 100% rename from physics/lsm_noah.f rename to physics/SFC_Models/Land/Noah/lsm_noah.f diff --git a/physics/lsm_noah.meta b/physics/SFC_Models/Land/Noah/lsm_noah.meta similarity index 99% rename from physics/lsm_noah.meta rename to physics/SFC_Models/Land/Noah/lsm_noah.meta index e059a22c6..f3ce1d19b 100644 --- a/physics/lsm_noah.meta +++ b/physics/SFC_Models/Land/Noah/lsm_noah.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = lsm_noah type = scheme - dependencies = funcphys.f90,machine.F,set_soilveg.f,sflx.f,surface_perturbation.F90 + dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F + dependencies = set_soilveg.f,sflx.f,surface_perturbation.F90,namelist_soilveg.f ######################################################################## [ccpp-arg-table] diff --git a/physics/namelist_soilveg.f b/physics/SFC_Models/Land/Noah/namelist_soilveg.f similarity index 100% rename from physics/namelist_soilveg.f rename to physics/SFC_Models/Land/Noah/namelist_soilveg.f diff --git a/physics/set_soilveg.f b/physics/SFC_Models/Land/Noah/set_soilveg.f similarity index 100% rename from physics/set_soilveg.f rename to physics/SFC_Models/Land/Noah/set_soilveg.f diff --git a/physics/sflx.f b/physics/SFC_Models/Land/Noah/sflx.f similarity index 100% rename from physics/sflx.f rename to physics/SFC_Models/Land/Noah/sflx.f diff --git a/physics/surface_perturbation.F90 b/physics/SFC_Models/Land/Noah/surface_perturbation.F90 similarity index 100% rename from physics/surface_perturbation.F90 rename to physics/SFC_Models/Land/Noah/surface_perturbation.F90 diff --git a/physics/module_sf_noahmp_glacier.F90 b/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 similarity index 99% rename from physics/module_sf_noahmp_glacier.F90 rename to physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 index 6e34c43af..fcbe40a70 100644 --- a/physics/module_sf_noahmp_glacier.F90 +++ b/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 @@ -2652,7 +2652,7 @@ subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in !to obtain equilibrium state of snow in glacier region - if(sneqv > mwd) then ! 100 mm -> maximum water depth + if(sneqv > mwd .and. isnow /= 0) then ! 100 mm -> maximum water depth bdsnow = snice(0) / dzsnso(0) snoflow = (sneqv - mwd) snice(0) = snice(0) - snoflow diff --git a/physics/module_sf_noahmplsm.F90 b/physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 similarity index 100% rename from physics/module_sf_noahmplsm.F90 rename to physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 diff --git a/physics/noahmp_tables.f90 b/physics/SFC_Models/Land/Noahmp/noahmp_tables.f90 similarity index 100% rename from physics/noahmp_tables.f90 rename to physics/SFC_Models/Land/Noahmp/noahmp_tables.f90 diff --git a/physics/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 similarity index 99% rename from physics/noahmpdrv.F90 rename to physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index c2c03d0de..6aff50666 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -136,7 +136,7 @@ subroutine noahmpdrv_run & iopt_trs,iopt_diag,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, rhonewsn1,& con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & - con_fvirt, con_rd, con_hfus, thsfc_loc, & + con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd, cpllnd2atm,& ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & @@ -310,6 +310,9 @@ subroutine noahmpdrv_run & logical , intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation + logical , intent(in) :: cpllnd ! Flag for land coupling (atm->lnd) + logical , intent(in) :: cpllnd2atm ! Flag for land coupling (lnd->atm) + real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! ground surface skin temperature [K] @@ -684,7 +687,12 @@ subroutine noahmpdrv_run & errmsg = '' errflg = 0 -do i = 1, im +! +! --- Just return if external land component is activated for two-way interaction +! + if (cpllnd .and. cpllnd2atm) return + + do i = 1, im if (flag_iter(i) .and. dry(i)) then diff --git a/physics/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta similarity index 98% rename from physics/noahmpdrv.meta rename to physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 820da5740..39eed1493 100644 --- a/physics/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = noahmpdrv type = scheme - dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90,set_soilveg.f + dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F + dependencies = module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90 + dependencies = ../Noah/set_soilveg.f ######################################################################## [ccpp-arg-table] @@ -633,6 +635,20 @@ dimensions = () type = logical intent = in +[cpllnd] + standard_name = flag_for_land_coupling + long_name = flag controlling cpllnd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cpllnd2atm] + standard_name = flag_for_one_way_land_coupling_to_atmosphere + long_name = flag controlling land coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land diff --git a/physics/noahmptable.tbl b/physics/SFC_Models/Land/Noahmp/noahmptable.tbl similarity index 100% rename from physics/noahmptable.tbl rename to physics/SFC_Models/Land/Noahmp/noahmptable.tbl diff --git a/physics/lsm_ruc.F90 b/physics/SFC_Models/Land/RUC/lsm_ruc.F90 similarity index 96% rename from physics/lsm_ruc.F90 rename to physics/SFC_Models/Land/RUC/lsm_ruc.F90 index 665fe6d14..ba1b1b4e9 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/SFC_Models/Land/RUC/lsm_ruc.F90 @@ -359,6 +359,8 @@ subroutine lsm_ruc_run & ! inputs & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & + & add_fire_heat_flux, fire_heat_flux_out, & + & frac_grid_burned_out, & ! --- out & rhosnf, sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & @@ -381,7 +383,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: oro, sigma real (kind_phys), dimension(:), intent(in) :: & - & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & + & t1, sigmaf, dlwflx, dswsfc, tg3, & & coszen, prsl1, wind, shdmin, shdmax, & & sfalb_lnd_bck, snoalb, zf, qc, q1, & ! for land @@ -417,7 +419,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: zs real (kind_phys), dimension(:), intent(in) :: srflag real (kind_phys), dimension(:), intent(inout) :: & - & canopy, trans, smcwlt2, smcref2, & + & canopy, trans, smcwlt2, smcref2, laixy, & ! for land & weasd_lnd, snwdph_lnd, tskin_lnd, & & tsurf_lnd, z0rl_lnd, tsnow_lnd, & @@ -430,6 +432,9 @@ subroutine lsm_ruc_run & ! inputs ! --- in real (kind_phys), dimension(:), intent(in) :: & & rainnc, rainc, ice, snow, graupel, rhonewsn1 + real (kind_phys), dimension(:), intent(in) :: fire_heat_flux_out, & + frac_grid_burned_out + logical, intent(in) :: add_fire_heat_flux ! --- in/out: ! --- on RUC levels real (kind_phys), dimension(:,:), intent(inout) :: & @@ -505,12 +510,13 @@ subroutine lsm_ruc_run & ! inputs & solnet_lnd, sfcexc, & & runoff1, runoff2, acrunoff, semis_bck, & & sfcems_lnd, hfx_lnd, shdfac, shdmin1d, shdmax1d, & + & fire_heat_flux1d, & & sneqv_lnd, snoalb1d_lnd, snowh_lnd, snoh_lnd, tsnav_lnd, & & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & - & precipfr, snfallac_lnd, acsn_lnd, & - & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq + & precipfr, snfallac_lnd, acsn_lnd, soilt1_lnd, chklowq, & + & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, smcwlt, smcref ! ice real (kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & @@ -540,7 +546,7 @@ subroutine lsm_ruc_run & ! inputs integer :: l, k, i, j, fractional_seaice, ilst real (kind_phys) :: dm, cimin(im) logical :: flag(im), flag_ice(im), flag_ice_uncoupled(im) - logical :: rdlai2d, myj, frpcpn + logical :: myj, frpcpn logical :: debug_print !-- diagnostic point @@ -645,15 +651,27 @@ subroutine lsm_ruc_run & ! inputs nsoil = lsoil_ruc do i = 1, im ! i - horizontal loop - ! reassign smcref2 and smcwlt2 to RUC values if(.not. land(i)) then !water and sea ice - smcref2 (i) = one - smcwlt2 (i) = zero + smcref (i,1) = one + smcwlt (i,1) = zero + xlai (i,1) = zero + elseif (kdt == 1) then + !land + ! reassign smcref2 and smcwlt2 to RUC values at kdt=1 + smcref (i,1) = REFSMC(stype(i)) + smcwlt (i,1) = WLTSMC(stype(i)) + !-- rdlai is .true. when the LAI data is available in the INPUT/sfc_data.nc on cold-start + if(rdlai) then + xlai(i,1) = laixy(i) + else + xlai(i,1) = LAITBL(vtype(i)) + endif else - !land - smcref2 (i) = REFSMC(stype(i)) - smcwlt2 (i) = WLTSMC(stype(i)) + !-- land and kdt > 1, parameters has sub-grid heterogeneity + smcref (i,1) = smcref2 (i) + smcwlt (i,1) = smcwlt2 (i) + xlai (i,1) = laixy (i) endif enddo @@ -813,10 +831,6 @@ subroutine lsm_ruc_run & ! inputs ffrozp(i,j) = real(nint(srflag(i)),kind_phys) endif - !-- rdlai is .false. when the LAI data is not available in the - ! - INPUT/sfc_data.nc - - rdlai2d = rdlai conflx2(i,1,j) = zf(i) * 2._kind_phys ! factor 2. is needed to get the height of ! atm. forcing inside RUC LSM (inherited @@ -843,14 +857,15 @@ subroutine lsm_ruc_run & ! inputs !!\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 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 +!!\n \a shdfac - areal fractional coverage of green vegetation (0.0-100.%) +!!\n \a shdmin - minimum areal fractional coverage of green vegetation in % -> !shdmin1d +!!\n \a shdmax - maximum areal fractional coverage of green vegetation in % -> !shdmax1d !!\n \a tbot - bottom soil temperature (local yearly-mean sfc air temp) lwdn(i,j) = dlwflx(i) !..downward lw flux at sfc in w/m2 swdn(i,j) = dswsfc(i) !..downward sw flux at sfc in w/m2 + ! all precip input to RUC LSM is in [mm] !prcp(i,j) = rhoh2o * tprcp(i) ! tprcp in [m] - convective plus explicit !raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip @@ -918,17 +933,12 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'MODIS landuse is not available' endif - if(rdlai2d) then - xlai(i,j) = laixy(i) - else - xlai(i,j) = zero - endif - semis_bck(i,j) = semisbase(i) ! --- units % shdfac(i,j) = sigmaf(i)*100._kind_phys shdmin1d(i,j) = shdmin(i)*100._kind_phys shdmax1d(i,j) = shdmax(i)*100._kind_phys + fire_heat_flux1d(i,j) = fire_heat_flux_out(i) ! JLS if (land(i)) then ! at least some land in the grid cell @@ -976,7 +986,6 @@ subroutine lsm_ruc_run & ! inputs snoalb1d_lnd(i,j) = snoalb(i) albbck_lnd(i,j) = min(0.9_kind_phys,albbcksol(i)) !sfalb_lnd_bck(i) - !-- spp_lsm if (spp_lsm == 1) then !-- spp for LSM is dimentioned as (1:lsoil_ruc) @@ -999,6 +1008,19 @@ subroutine lsm_ruc_run & ! inputs alb_lnd(i,j) = albbck_lnd(i,j) * (one-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) solnet_lnd(i,j) = dswsfc(i)*(one-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 + IF ( add_fire_heat_flux .and. fire_heat_flux_out(i) > 0) then ! JLS + if (debug_print) then + print *,'alb_lnd before fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i) + print *,'fire_heat_flux_out, frac_grid_burned_out, xlat/xlon ', & + fire_heat_flux_out(i),frac_grid_burned_out(i),xlat_d(i),xlon_d(i) + endif + ! limit albedo in the areas affected by the fire + alb_lnd(i,j) = alb_lnd(i,j) * (one-frac_grid_burned_out(i)) + 0.08_kind_phys*frac_grid_burned_out(i) + if (debug_print) then + print *,'alb_lnd after fire, xlat/xlon ', alb_lnd(i,j), xlat_d(i),xlon_d(i) + endif + ENDIF + cmc(i,j) = canopy(i) ! [mm] soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow @@ -1163,7 +1185,7 @@ subroutine lsm_ruc_run & ! inputs & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & & xlai(i,j), landusef(i,:,j), nlcat, & - & soilctop(i,:,j), nscat, & + & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), & & qsfc_lnd(i,j), qsg_lnd(i,j), qvg_lnd(i,j), qcg_lnd(i,j), & & dew_lnd(i,j), soilt1_lnd(i,j), & & tsnav_lnd(i,j), tbot(i,j), vtype_lnd(i,j), stype_lnd(i,j), & @@ -1178,8 +1200,9 @@ subroutine lsm_ruc_run & ! inputs & 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_lnd(i,j), snomlt_lnd(i,j), & - & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & - & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & + & smfrsoil(i,:,j),keepfrsoil(i,:,j), & + & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., & + & shdmin1d(i,j), shdmax1d(i,j), rdlai, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, errmsg, errflg ) if(debug_print) then @@ -1218,7 +1241,7 @@ subroutine lsm_ruc_run & ! inputs '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) + 'snomlt(i,j) =',snomlt_lnd(i,j),'xlai(i,j) =',xlai(i,j) endif endif @@ -1289,6 +1312,10 @@ subroutine lsm_ruc_run & ! inputs ! --- ... unit conversion (from m to mm) snwdph_lnd(i) = snowh_lnd(i,j) * rhoh2o + laixy(i) = xlai(i,j) + smcwlt2(i) = smcwlt(i,j) + smcref2(i) = smcref(i,j) + canopy(i) = cmc(i,j) ! mm weasd_lnd(i) = sneqv_lnd(i,j) ! mm sncovr1_lnd(i) = sncovr_lnd(i,j) @@ -1318,6 +1345,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'LAND -i,j,stype_lnd,vtype_lnd',i,j,stype_lnd(i,j),vtype_lnd(i,j) write (0,*)'i,j,tsurf_lnd(i)',i,j,tsurf_lnd(i) write (0,*)'kdt,iter,stsoil(i,:,j)',kdt,iter,stsoil(i,:,j) + write (0,*)'laixy(i)',laixy(i) endif endif ! end of land @@ -1449,7 +1477,7 @@ subroutine lsm_ruc_run & ! inputs & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & & albbck_ice(i,j), xlai(i,j),landusef(i,:,j), nlcat, & - & soilctop(i,:,j), nscat, & + & soilctop(i,:,j), nscat, smcwlt(i,j), smcref(i,j), & & qsfc_ice(i,j), qsg_ice(i,j), qvg_ice(i,j), qcg_ice(i,j), & & dew_ice(i,j), soilt1_ice(i,j), & & tsnav_ice(i,j), tbot(i,j), vtype_ice(i,j), stype_ice(i,j), & @@ -1464,8 +1492,9 @@ subroutine lsm_ruc_run & ! inputs & 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_ice(i,j), snomlt_ice(i,j), & - & smfrice(i,:,j),keepfrice(i,:,j), .false., & - & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & + & smfrice(i,:,j),keepfrice(i,:,j), & + & add_fire_heat_flux,fire_heat_flux1d(i,j), .false., & + & shdmin1d(i,j), shdmax1d(i,j), rdlai, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, & & errmsg, errflg) @@ -1502,6 +1531,10 @@ subroutine lsm_ruc_run & ! inputs albivis_ice(i) = sfalb_ice(i) albinir_ice(i) = sfalb_ice(i) + laixy(i) = zero + smcwlt2(i) = zero + smcref2(i) = one + stm(i) = 3.e3_kind_phys ! kg m-2 do k = 1, lsoil_ruc tsice(i,k) = stsice(i,k,j) @@ -1517,6 +1550,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'ICE - i,j,stype_ice,vtype_ice)',i,j,stype_ice(i,j),vtype_ice(i,j) write (0,*)'i,j,tsurf_ice(i)',i,j,tsurf_ice(i) write (0,*)'kdt,iter,stsice(i,:,j)',kdt,iter,stsice(i,:,j) + write (0,*)'laixy(i)',laixy(i) endif endif ! ice @@ -1762,6 +1796,8 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vtype(i) isltyp(i,j) = stype(i) + if(isltyp(i,j)==0) isltyp(i,j)=14 + if(ivgtyp(i,j)==0) ivgtyp(i,j)=17 if (landfrac(i) > zero .or. fice(i) > zero) then !-- land or ice tsk(i,j) = tskin_lnd(i) diff --git a/physics/lsm_ruc.meta b/physics/SFC_Models/Land/RUC/lsm_ruc.meta similarity index 98% rename from physics/lsm_ruc.meta rename to physics/SFC_Models/Land/RUC/lsm_ruc.meta index 34a5b8a8b..bc4d358e3 100644 --- a/physics/lsm_ruc.meta +++ b/physics/SFC_Models/Land/RUC/lsm_ruc.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = lsm_ruc type = scheme - dependencies = machine.F,module_sf_ruclsm.F90,module_soil_pre.F90,namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 + dependencies = ../../../hooks/machine.F,../../../hooks/physcons.F90 + dependencies = module_sf_ruclsm.F90,module_soil_pre.F90,namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 ######################################################################## [ccpp-arg-table] @@ -813,7 +814,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout [dlwflx] standard_name = surface_downwelling_longwave_flux long_name = surface downwelling longwave flux at current time @@ -1747,6 +1748,29 @@ dimensions = () type = logical intent = in +[add_fire_heat_flux] + standard_name = flag_for_fire_heat_flux + long_name = flag to add fire heat flux to LSM + units = flag + dimensions = () + type = logical + intent = in +[fire_heat_flux_out] + standard_name = surface_fire_heat_flux + long_name = heat flux of fire at the surface + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[frac_grid_burned_out] + standard_name = fraction_of_grid_cell_burning + long_name = ration of the burnt area to the grid cell area + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_sf_ruclsm.F90 b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 similarity index 97% rename from physics/module_sf_ruclsm.F90 rename to physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 index 160127e43..2d01f96c9 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 @@ -97,6 +97,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & MAVAIL,CANWAT,VEGFRA, & ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, soilctop, nscat, & + smcwlt, smcref, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & TBOT,IVGTYP,ISLTYP,XLAND, & ISWATER,ISICE,XICE,XICE_THRESHOLD, & @@ -107,6 +108,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, & SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & + add_fire_heat_flux,fire_heat_flux, & myj,shdmin,shdmax,rdlai2d, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -239,6 +241,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev + LOGICAL, intent(in) :: add_fire_heat_flux + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: fire_heat_flux LOGICAL, intent(in) :: rdlai2d real (kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS @@ -252,6 +256,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & SNOALB, & ALB, & LAI, & + SMCWLT, & + SMCREF, & EMISS, & EMISBCK, & MAVAIL, & @@ -757,6 +763,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !-- update background emissivity for land points, can have vegetation mosaic effect EMISBCK(I,J) = EMISSL(I,J) + smcwlt(i,j) = wilt + smcref(i,j) = ref IF (debug_print ) THEN if(init)then @@ -961,6 +969,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & snoalb(i,j),albbck(i,j),lai(i,j), & hgt(i,j),stdev(i,j), & !new myj,seaice(i,j),isice, & + add_fire_heat_flux,fire_heat_flux(i,j), & !--- soil fixed fields QWRTZ, & rhocs,dqm,qmin,ref, & @@ -1212,6 +1221,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia QKMS,TKMS,PC,MAVAIL,CST,VEGFRA,ALB,ZNT, & ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, & MYJ,SEAICE,ISICE, & + add_fire_heat_flux,fire_heat_flux, & QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & !--- constants @@ -1256,7 +1266,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SEAICE, & RHO, & QKMS, & - TKMS + TKMS, & + fire_heat_flux + LOGICAL, INTENT(IN ) :: add_fire_heat_flux INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables @@ -1509,7 +1521,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF if(snhei.gt.0.0081_kind_phys*rhowater/rhosn) then -!*** Update snow density for current temperature (Koren et al. 1999) +!*** Update snow density for current temperature (Koren et al 1999,doi:10.1029/1999JD900232.) BSN=delt/3600._kind_phys*c1sn*exp(0.08_kind_phys*min(zero,tsnav)-c2sn*rhosn*1.e-3_kind_phys) if(bsn*snwe*100._kind_phys.lt.1.e-4_kind_phys) goto 777 XSN=rhosn*(exp(bsn*snwe*100._kind_phys)-one)/(bsn*snwe*100._kind_phys) @@ -1675,7 +1687,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif if(newsn > zero ) then - SNOWFRACnewsn=MIN(one,SNHEI/SNHEI_CRIT_newsn) + SNOWFRACnewsn=MIN(one,snowfallac*1.e-3_kind_phys/SNHEI_CRIT_newsn) endif !-- due to steep slopes and blown snow, limit snow fraction in the @@ -1688,10 +1700,11 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(snowfrac < 0.75_kind_phys) snow_mosaic = one KEEP_SNOW_ALBEDO = zero - IF (NEWSN > zero .and. snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN + IF (snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN ! new snow KEEP_SNOW_ALBEDO = one - !snow_mosaic=0. ! ??? + ! turn off separate treatment of snow covered and snow-free portions of the grid cell + snow_mosaic=0. ! ??? ENDIF IF (debug_print ) THEN @@ -1722,7 +1735,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! hwlps with these biases.. if( snow_mosaic == one) then ALBsn=alb_snow - if(newsn > zero .and. KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then + if(KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). @@ -1813,6 +1826,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia UPFLUX = T3 *SOILT XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET + IF ( add_fire_heat_flux .and. fire_heat_flux >0 ) then ! JLS + IF (debug_print ) THEN + print *,'RNET snow-free, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + ENDIF + RNET = RNET + fire_heat_flux + ENDIF + IF (debug_print ) THEN print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet @@ -1837,7 +1857,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ilands = ivgtyp - CALL SOIL(debug_print,xlat,xlon, & + CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & @@ -1933,6 +1953,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if (SEAICE .LT. 0.5_kind_phys) then ! LAND + IF ( add_fire_heat_flux .and. fire_heat_flux>0 ) then ! JLS + IF (debug_print ) THEN + print *,'RNET snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + ENDIF + RNET = RNET + fire_heat_flux + ENDIF if(snow_mosaic==one)then snfr=one else @@ -2051,7 +2077,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia hfx = hfxs*(one-snowfrac) + hfx*snowfrac s = ss*(one-snowfrac) + s*snowfrac evapl = evapls*(one-snowfrac) - sublim = sublim*snowfrac prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac fltot = fltots*(one-snowfrac) + fltot*snowfrac ALB = MAX(keep_snow_albedo*alb, & @@ -2063,10 +2088,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac - smelt = smelt * snowfrac - snoh = snoh * snowfrac - snflx = snflx * snowfrac - snom = snom * snowfrac mavail = mavails*(one-snowfrac) + one*snowfrac infiltr = infiltrs*(one-snowfrac) + infiltr*snowfrac @@ -2090,7 +2111,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qvg = qvgs*(one-snowfrac) + qvg*snowfrac qsg = qsgs*(one-snowfrac) + qsg*snowfrac qcg = qcgs*(one-snowfrac) + qcg*snowfrac - sublim = eeta*snowfrac + sublim = eeta eeta = eetas*(one-snowfrac) + eeta*snowfrac qfx = qfxs*(one-snowfrac) + qfx*snowfrac hfx = hfxs*(one-snowfrac) + hfx*snowfrac @@ -2104,10 +2125,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia (emissn - emiss_snowfree) * snowfrac), emissn)) runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac - smelt = smelt * snowfrac - snoh = snoh * snowfrac - snflx = snflx * snowfrac - snom = snom * snowfrac IF (debug_print ) THEN print *,'SOILT combined on ice', soilt ENDIF @@ -2190,15 +2207,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia IF (debug_print ) then !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then print *,'Snowfallac xlat, xlon',xlat,xlon - print *,'newsn,rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio + print *,'newsn [m],rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio print *,'Time-step newsn depth [m], swe [m]',newsn,newsn*rhonewsn print *,'Time-step smelt: swe [m]' ,smelt*delt print *,'Time-step sublim: swe,[kg m-2]',sublim*delt endif - snowfallac = snowfallac + max(zero,(newsn*rhonewsn - & ! source of snow (swe) [m] - (smelt+sublim*1.e-3_kind_phys)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] - /rhonewsn)*rhowater ! snow accumulation in snow depth [mm] + snowfallac = snowfallac + newsn * 1.e3_kind_phys ! accumulated snow depth [mm], using variable snow density IF (debug_print ) THEN !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then @@ -2223,7 +2238,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5_kind_phys) then ! LAND - CALL SOIL(debug_print,xlat,xlon, & + IF ( add_fire_heat_flux .and. fire_heat_flux>0) then ! JLS + IF (debug_print ) THEN + print *,'RNET no snow, fire_heat_flux, xlat/xlon',RNET, fire_heat_flux,xlat,xlon + endif + RNET = RNET + fire_heat_flux + ENDIF + + CALL SOIL(debug_print,xlat, xlon, testptlat, testptlon,& !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & @@ -2316,7 +2338,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,xlat,xlon, & + SUBROUTINE SOIL (debug_print,xlat,xlon,testptlat,testptlon,& i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,GSWin,EMISS,RNET, & @@ -2398,7 +2420,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX + real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables real (kind_phys), & @@ -2622,6 +2645,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! hydraulic condeuctivities !****************************************************************** CALL SOILPROP( debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & @@ -2657,6 +2681,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! TRANSF computes transpiration function !************************************************************** CALL TRANSF(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -2714,7 +2739,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! SOILTEMP soilves heat budget and diffusion eqn. in soil !************************************************************** - CALL SOILTEMP(debug_print,xlat,xlon, & + CALL SOILTEMP(debug_print,xlat,xlon,testptlat,testptlon,& !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -2784,6 +2809,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! and Richards eqn. !************************************************************************* CALL SOILMOIST (debug_print, & + xlat, xlon, testptlat, testptlon, & !-- input delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & @@ -3578,6 +3604,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! hydraulic condeuctivities !****************************************************************** CALL SOILPROP(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & @@ -3628,6 +3655,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! TRANSF computes transpiration function !************************************************************** CALL TRANSF(debug_print, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -3723,7 +3751,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28) ! AND TSO,ETA PROFILES !************************************************************************* - CALL SOILMOIST (debug_print, & + CALL SOILMOIST (debug_print,xlat,xlon,testptlat,testptlon,& !-- input delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & @@ -4046,35 +4074,25 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOnewCSN=sheatsn * RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4510,35 +4528,25 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4679,7 +4687,7 @@ END SUBROUTINE SNOWSEAICE !>\ingroup lsm_ruc_group !> This subroutine solves energy budget equation and heat diffusion !! equation. - SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & + SUBROUTINE SOILTEMP( debug_print,xlat,xlon,testptlat,testptlon,& i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & @@ -4749,7 +4757,8 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables real (kind_phys), & @@ -5193,27 +5202,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN RHOnewCSN=sheatsn* RHOnewSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys if(debug_print) then print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn @@ -5223,12 +5221,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5587,7 +5586,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nmelt = 1 soiltfrac=snowfrac*tfrz+(one-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) - qvg=qsg + qvg=snowfrac*qsg+(one-snowfrac)*qvg T3 = STBOLT*TN*TN*TN UPFLUX = T3 * 0.5_kind_phys*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) @@ -5776,27 +5775,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then - !-- some areas with large snow depth have unrealistically - !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. - !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys - else - !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265_kind_phys/RHOCSN - endif + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) fact = one if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys - !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5._kind_phys else keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys - fact = 2._kind_phys if(debug_print) then print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn @@ -5807,12 +5795,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact endif - if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then + if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). - !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7 !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6_kind_phys + thdifsn = 4.431718e-7_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5959,6 +5948,7 @@ END SUBROUTINE SNOWTEMP !! This subroutine solves moisture budget and computes soil moisture !! and surface and sub-surface runoffs. SUBROUTINE SOILMOIST ( debug_print, & + xlat, xlon, testptlat, testptlon, & DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW, & !--- input parameters ZSMAIN,ZSHALF,DIFFU,HYDRO, & QSG,QVG,QCG,QCATM,QVATM,PRCP, & @@ -6012,6 +6002,7 @@ SUBROUTINE SOILMOIST ( debug_print, & !--- input variables LOGICAL, INTENT(IN ) :: debug_print real (kind_phys), INTENT(IN ) :: DELT + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon INTEGER, INTENT(IN ) :: NZS,NDDZS ! input variables @@ -6099,8 +6090,12 @@ SUBROUTINE SOILMOIST ( debug_print, & DENOM=one+X2+X4-Q2*COSMC(K) COSMC(K+1)=Q4/DENOM IF (debug_print ) THEN - print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & - ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & + ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k + endif ENDIF RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & +TRANSP(KN) & @@ -6131,8 +6126,12 @@ SUBROUTINE SOILMOIST ( debug_print, & TOTLIQ=PRCP-DRIP/DELT-(one-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 + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & + UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT + endif ENDIF FLX=TOTLIQ @@ -6175,7 +6174,7 @@ SUBROUTINE SOILMOIST ( debug_print, & INFMAX1 = zero ENDIF IF (debug_print ) THEN - print *,'INFMAX1 before frozen part',INFMAX1 + print *,'INFMAX1 before frozen part',INFMAX1 ENDIF ! ----------- FROZEN GROUND VERSION -------------------------- @@ -6209,8 +6208,8 @@ SUBROUTINE SOILMOIST ( debug_print, & INFMAX = MAX(INFMAX1,HYDRO(1)*SOILMOIS(1)) INFMAX = MIN(INFMAX, -TOTLIQ) IF (debug_print ) THEN -print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & - INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ + print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & + INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ ENDIF !---- IF (-TOTLIQ.GT.INFMAX)THEN @@ -6260,8 +6259,12 @@ SUBROUTINE SOILMOIST ( debug_print, & END IF IF (debug_print ) THEN - print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw - print *,'COSMC,RHSMC',COSMC,RHSMC + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw + print *,'COSMC,RHSMC',COSMC,RHSMC + endif ENDIF !--- FINAL SOLUTION FOR SOILMOIS ! DO K=2,NZS1 @@ -6287,7 +6290,11 @@ SUBROUTINE SOILMOIST ( debug_print, & END IF END DO IF (debug_print ) THEN - print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw + endif ENDIF MAVAIL=max(.00001_kind_phys,min(one,(SOILMOIS(1)/(REF-QMIN)*(one-snowfrac)+one*snowfrac))) @@ -6299,6 +6306,7 @@ END SUBROUTINE SOILMOIST !! This subroutine computes thermal diffusivity, and diffusional and !! hydraulic condeuctivities in soil. SUBROUTINE SOILPROP( debug_print, & + xlat, xlon, testptlat, testptlon, & nzs,fwsat,lwsat,tav,keepfr, & !--- input variables soilmois,soiliqw,soilice, & soilmoism,soiliqwm,soilicem, & @@ -6332,6 +6340,8 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS + real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & @@ -6508,6 +6518,7 @@ END SUBROUTINE SOILPROP !> This subroutine solves the transpiration function (EQs. 18,19 in !! Smirnova et al.(1997) \cite Smirnova_1997) SUBROUTINE TRANSF( debug_print, & + xlat,xlon,testptlat,testptlon, & nzs,nroot,soiliqw,tabs,lai,gswin, & !--- input variables dqm,qmin,ref,wilt,zshalf,pc,iland, & !--- soil fixed fields tranf,transum) !--- output variables @@ -6528,6 +6539,7 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland + real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon real (kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai @@ -6574,7 +6586,7 @@ SUBROUTINE TRANSF( debug_print, & ap4=59.656_kind_phys gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 if(totliq.ge.ref) gx=one - if(totliq.le.zero) gx=zero + if(totliq.le.wilt) gx=zero if(gx.gt.one) gx=one if(gx.lt.zero) gx=zero DID=zshalf(2) @@ -6587,7 +6599,7 @@ SUBROUTINE TRANSF( debug_print, & TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution - TRANF(1)=part(1) + !TRANF(1)=part(1) DO K=2,NROOT totliq=soiliqw(k)+qmin @@ -6597,7 +6609,7 @@ SUBROUTINE TRANSF( debug_print, & sm4=sm3*sm1 gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 if(totliq.ge.ref) gx=one - if(totliq.le.zero) gx=zero + if(totliq.le.wilt) gx=zero if(gx.gt.one) gx=one if(gx.lt.zero) gx=zero DID=zshalf(K+1)-zshalf(K) @@ -6611,8 +6623,16 @@ SUBROUTINE TRANSF( debug_print, & /(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution -! TRANF(k)=part(k) + !TRANF(k)=part(k) END DO + IF (debug_print ) THEN + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'soiliqw =',soiliqw,'wilt=',wilt,'qmin= ',qmin + print *,'tranf = ',tranf + endif + ENDIF ! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013) if(lai > 4._kind_phys) then @@ -6624,7 +6644,11 @@ SUBROUTINE TRANSF( debug_print, & ! pctot=min(0.8,max(pc,pc*lai)) endif IF ( debug_print ) THEN - print *,'pctot,lai,pc',pctot,lai,pc + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'pctot,lai,pc',pctot,lai,pc + endif ENDIF !--- !--- air temperature function @@ -6634,9 +6658,6 @@ SUBROUTINE TRANSF( debug_print, & ELSE FTEM = one / (one + EXP(0.5_kind_phys * (TABS - 314.0_kind_phys))) ENDIF - IF ( debug_print ) THEN - print *,'tabs,ftem',tabs,ftem - ENDIF !--- incoming solar function cmin = one/rsmax_data cmax = one/rstbl(iland) @@ -6659,27 +6680,33 @@ SUBROUTINE TRANSF( debug_print, & else fsol = one endif - IF ( debug_print ) THEN - print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol - ENDIF !--- total conductance totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax IF ( debug_print ) THEN - print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & - ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol',GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol + print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & + ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd + endif ENDIF !-- TRANSUM - total for the rooting zone transum=zero DO K=1,NROOT ! linear root distribution - TRANF(k)=max(cmin,TRANF(k)*totcnd) + TRANF(k)=max(zero,TRANF(k)*totcnd) transum=transum+tranf(k) END DO IF ( debug_print ) THEN - print *,'transum,TRANF',transum,tranf - endif + if (abs(xlat-testptlat).lt.0.05 .and. & + abs(xlon-testptlon).lt.0.05)then + print *,'xlat,xlon=',xlat,xlon + print *,'transum,TRANF',transum,tranf + endif + ENDIF !----------------------------------------------------------------- END SUBROUTINE TRANSF diff --git a/physics/module_soil_pre.F90 b/physics/SFC_Models/Land/RUC/module_soil_pre.F90 similarity index 100% rename from physics/module_soil_pre.F90 rename to physics/SFC_Models/Land/RUC/module_soil_pre.F90 diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 similarity index 100% rename from physics/namelist_soilveg_ruc.F90 rename to physics/SFC_Models/Land/RUC/namelist_soilveg_ruc.F90 diff --git a/physics/set_soilveg_ruc.F90 b/physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 similarity index 100% rename from physics/set_soilveg_ruc.F90 rename to physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 diff --git a/physics/SFC_Models/Land/sfc_land.F90 b/physics/SFC_Models/Land/sfc_land.F90 new file mode 100644 index 000000000..2b0696ed8 --- /dev/null +++ b/physics/SFC_Models/Land/sfc_land.F90 @@ -0,0 +1,108 @@ +!> \file sfc_land.F90 +!! This file contains the code for coupling to land component + +!> This module contains the CCPP-compliant GFS land post +!! interstitial codes, which returns updated surface +!! properties such as latent heat and sensible heat +!! provided by the component version of land model + +!> This module contains the CCPP-compliant GFS land scheme. + module sfc_land + + use machine, only : kind_phys + + contains + +!> \defgroup sfc_land for coupling to land +!! @{ +!! \section diagram Calling Hierarchy Diagram +!! \section intraphysics Intraphysics Communication +!! +!> \brief Brief description of the subroutine +!! +!! \section arg_table_sfc_land_run Arguments +!! \htmlinclude sfc_land_run.html +!! + +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine sfc_land_run(im, cpllnd, cpllnd2atm, flag_iter, dry, & + sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & + ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, & + runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, zvfun_lnd, & + sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & + gflux, runoff, drain, cmm, chh, zvfun, & + errmsg, errflg) + + implicit none + + ! Inputs + integer , intent(in) :: im + logical , intent(in) :: cpllnd + logical , intent(in) :: cpllnd2atm + logical , intent(in) :: flag_iter(:) + logical , intent(in) :: dry(:) + real(kind=kind_phys), intent(in) :: sncovr1_lnd(:) + real(kind=kind_phys), intent(in) :: qsurf_lnd(:) + real(kind=kind_phys), intent(in) :: evap_lnd(:) + real(kind=kind_phys), intent(in) :: hflx_lnd(:) + real(kind=kind_phys), intent(in) :: ep_lnd(:) + real(kind=kind_phys), intent(in) :: t2mmp_lnd(:) + real(kind=kind_phys), intent(in) :: q2mp_lnd(:) + real(kind=kind_phys), intent(in) :: gflux_lnd(:) + real(kind=kind_phys), intent(in) :: runoff_lnd(:) + real(kind=kind_phys), intent(in) :: drain_lnd(:) + real(kind=kind_phys), intent(in) :: cmm_lnd(:) + real(kind=kind_phys), intent(in) :: chh_lnd(:) + real(kind=kind_phys), intent(in) :: zvfun_lnd(:) + ! Inputs/Outputs + real(kind=kind_phys), intent(inout) :: sncovr1(:) + real(kind=kind_phys), intent(inout) :: qsurf(:) + real(kind=kind_phys), intent(inout) :: evap(:) + real(kind=kind_phys), intent(inout) :: hflx(:) + real(kind=kind_phys), intent(inout) :: ep(:) + real(kind=kind_phys), intent(inout) :: t2mmp(:) + real(kind=kind_phys), intent(inout) :: q2mp(:) + real(kind=kind_phys), intent(inout) :: gflux(:) + real(kind=kind_phys), intent(inout) :: runoff(:) + real(kind=kind_phys), intent(inout) :: drain(:) + real(kind=kind_phys), intent(inout) :: cmm(:) + real(kind=kind_phys), intent(inout) :: chh(:) + real(kind=kind_phys), intent(inout) :: zvfun(:) + ! Outputs + character(len=*) , intent(out) :: errmsg + integer , intent(out) :: errflg + + ! Locals + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Check coupling from component land to atmosphere + if (.not. cpllnd2atm) return + + ! Fill variables + do i = 1, im + sncovr1(i) = sncovr1_lnd(i) + qsurf(i) = qsurf_lnd(i) + hflx(i) = hflx_lnd(i) + evap(i) = evap_lnd(i) + ep(i) = ep_lnd(i) + t2mmp(i) = t2mmp_lnd(i) + q2mp(i) = q2mp_lnd(i) + gflux(i) = gflux_lnd(i) + drain(i) = drain_lnd(i) + runoff(i) = runoff_lnd(i) + cmm(i) = cmm_lnd(i) + chh(i) = chh_lnd(i) + zvfun(i) = zvfun_lnd(i) + enddo + + end subroutine sfc_land_run + +!> @} + end module sfc_land diff --git a/physics/SFC_Models/Land/sfc_land.meta b/physics/SFC_Models/Land/sfc_land.meta new file mode 100644 index 000000000..6a4bd8fbe --- /dev/null +++ b/physics/SFC_Models/Land/sfc_land.meta @@ -0,0 +1,267 @@ +[ccpp-table-properties] + name = sfc_land + type = scheme + dependencies = ../../hooks/machine.F + +######################################################################## +[ccpp-arg-table] + name = sfc_land_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[cpllnd] + standard_name = flag_for_land_coupling + long_name = flag controlling cpllnd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cpllnd2atm] + standard_name = flag_for_one_way_land_coupling_to_atmosphere + long_name = flag controlling land coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[sncovr1_lnd] + standard_name = surface_snow_area_fraction_over_land_from_land + long_name = surface snow area fraction over land for coupling + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[qsurf_lnd] + standard_name = surface_specific_humidity_over_land_from_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[evap_lnd] + standard_name = surface_upward_latent_heat_flux_over_land_from_land + long_name = sfc latent heat flux input over land for coupling + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[hflx_lnd] + standard_name = surface_upward_sensible_heat_flux_over_land_from_land + long_name = sfc sensible heat flux input over land for coupling + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ep_lnd] + standard_name = surface_upward_potential_latent_heat_flux_over_land_from_land + long_name = surface upward potential latent heat flux over land for coupling + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t2mmp_lnd] + standard_name = temperature_at_2m_over_land_from_land + long_name = 2 meter temperature over land for coupling + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[q2mp_lnd] + standard_name = specific_humidity_at_2m_over_land_from_land + long_name = 2 meter specific humidity over land for coupling + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gflux_lnd] + standard_name = upward_heat_flux_in_soil_over_land_from_land + long_name = soil heat flux over land for coupling + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[runoff_lnd] + standard_name = surface_runoff_flux_from_land + long_name = surface runoff flux over land for coupling + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[drain_lnd] + standard_name = subsurface_runoff_flux_from_land + long_name = subsurface runoff flux over land for coupling + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cmm_lnd] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land_from_land + long_name = momentum exchange coefficient over land for coupling + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[chh_lnd] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land_from_land + long_name = thermal exchange coefficient over land for coupling + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zvfun_lnd] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction_from_land + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sncovr1] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[qsurf] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t2mmp] + standard_name = temperature_at_2m_from_noahmp + long_name = 2 meter temperature from noahmp + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[q2mp] + standard_name = specific_humidity_at_2m_from_noahmp + long_name = 2 meter specific humidity from noahmp + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gflux] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[runoff] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land + long_name = momentum exchange coefficient over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land + long_name = thermal exchange coefficient over land + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/sfc_ocean.F b/physics/SFC_Models/Ocean/UFS/sfc_ocean.F similarity index 100% rename from physics/sfc_ocean.F rename to physics/SFC_Models/Ocean/UFS/sfc_ocean.F diff --git a/physics/sfc_ocean.meta b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta similarity index 99% rename from physics/sfc_ocean.meta rename to physics/SFC_Models/Ocean/UFS/sfc_ocean.meta index 15812e723..848c2e3ed 100644 --- a/physics/sfc_ocean.meta +++ b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sfc_ocean type = scheme - dependencies = funcphys.f90,machine.F + dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_cice.f b/physics/SFC_Models/SeaIce/CICE/sfc_cice.f similarity index 100% rename from physics/sfc_cice.f rename to physics/SFC_Models/SeaIce/CICE/sfc_cice.f diff --git a/physics/sfc_cice.meta b/physics/SFC_Models/SeaIce/CICE/sfc_cice.meta similarity index 99% rename from physics/sfc_cice.meta rename to physics/SFC_Models/SeaIce/CICE/sfc_cice.meta index 796fb2f5d..c44f9d6b5 100644 --- a/physics/sfc_cice.meta +++ b/physics/SFC_Models/SeaIce/CICE/sfc_cice.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_cice type = scheme - dependencies = machine.F + relative_path = ../../../ + dependencies = hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sfc_sice.f b/physics/SFC_Models/SeaIce/CICE/sfc_sice.f similarity index 100% rename from physics/sfc_sice.f rename to physics/SFC_Models/SeaIce/CICE/sfc_sice.f diff --git a/physics/sfc_sice.meta b/physics/SFC_Models/SeaIce/CICE/sfc_sice.meta similarity index 99% rename from physics/sfc_sice.meta rename to physics/SFC_Models/SeaIce/CICE/sfc_sice.meta index 75aab21a4..828a83939 100644 --- a/physics/sfc_sice.meta +++ b/physics/SFC_Models/SeaIce/CICE/sfc_sice.meta @@ -1,7 +1,8 @@ [ccpp-table-properties] name = sfc_sice type = scheme - dependencies = funcphys.f90,machine.F + relative_path = ../../../ + dependencies = tools/funcphys.f90,hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/gfs_phy_tracer_config.F b/physics/gfs_phy_tracer_config.F deleted file mode 100644 index 647919a23..000000000 --- a/physics/gfs_phy_tracer_config.F +++ /dev/null @@ -1,228 +0,0 @@ - -! -!! ! Module: gfs_phy_tracer_config -! -! ! Description: gfs physics tracer configuration module -! -! ! Revision history: -! Oct 16 2009 Sarah Lu, adopted from dyn fc -! Nov 21 2009 Sarah Lu, chem tracer specified from ChemRegistry -! Dec 10 2009 Sarah Lu, add doing_GOCART -! Jan 12 2010 Sarah Lu, add trcindx -! Feb 08 2009 Sarah Lu, ri/cpi added to gfs_phy_tracer_type -! Aug 17 2010 Sarah Lu, remove debug print -! Oct 16 2010 Sarah Lu, add fscav -! Aug 08 2011 Jun Wang, remove gocart dependency when not running GOCART -! Sep 17 2011 Sarah Lu, revise chem tracer initialization -! Nov 11 2011 Sarah Lu, allocate but not assign value for cpi/ri array -! Apr 06 2012 Henry Juang, relax hardwire num_tracer, add tracer 4 and 5 -! Apr 23 2012 Jun Wang, remove save attibute for gfs_phy_tracer (already defined) -! --- -- 2016 Anning Cheng add ntiw,ntlnc,ntinc -! May 03 2016 S Moorthi add nto, nto2 -! ------------------------------------------------------------------------- -! - module gfs_phy_tracer_config - use machine , only : kind_phys - - implicit none - SAVE -! -! tracer specification: add fscav -! - type gfs_phy_tracer_type - character*20 , pointer :: chem_name(:) ! chem_tracer name - character*20 , pointer :: vname(:) ! variable name - real(kind=kind_phys), pointer :: ri(:) - real(kind=kind_phys), pointer :: cpi(:) - real(kind=kind_phys), pointer :: fscav(:) - integer :: ntrac, ntrac_met, ntrac_chem - logical :: doing_DU, doing_SU, doing_SS - &, doing_OC, doing_BC, doing_GOCART - endtype gfs_phy_tracer_type - - type (gfs_phy_tracer_type) :: gfs_phy_tracer -! -! misc tracer options -! - logical :: glbsum = .true. -! - -! --- public interface - public tracer_config_init, trcindx - - contains - -! ------------------------------------------------------------------- -! ------------------------------------------------------------------- -! subroutine tracer_config_init (gfs_phy_tracer,ntrac, - subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, - & ntiw,ntlnc,ntinc, - & fprcp,ntrw,ntsw,ntrnc,ntsnc, - & ntke,nto,nto2,me) - -c -c This subprogram sets up gfs_phy_tracer -c - implicit none -! input - integer, intent(in) :: me, ntoz,ntcw,ntke, - & ntiw,ntlnc,ntinc,nto,nto2, - & fprcp,ntrw,ntsw,ntrnc,ntsnc -! output -! type (gfs_phy_tracer_type), intent(out) :: gfs_phy_tracer -! input/output - integer, intent(inout) :: ntrac -! local - integer :: i, j, status, ierr - character*20 :: rgname - -! initialize ntrac_chem (the default is no chemistry) - gfs_phy_tracer%ntrac_chem = 0 - gfs_phy_tracer%doing_GOCART = .false. - -! initialize chem tracers - call gocart_tracer_config(me) - -! input ntrac is meteorological tracers - gfs_phy_tracer%ntrac_met = ntrac - -! update ntrac = total number of tracers - gfs_phy_tracer%ntrac = gfs_phy_tracer%ntrac_met + - & gfs_phy_tracer%ntrac_chem - ntrac = gfs_phy_tracer%ntrac - - if(me==0) then - print *, 'LU_TRCp: ntrac_met =',gfs_phy_tracer%ntrac_met - print *, 'LU_TRCp: ntrac_chem=',gfs_phy_tracer%ntrac_chem - print *, 'LU_TRCp: ntrac =',gfs_phy_tracer%ntrac - endif - -! Set up tracer name, cpi, and ri - if ( gfs_phy_tracer%ntrac > 0 ) then - allocate(gfs_phy_tracer%vname(ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - allocate(gfs_phy_tracer%ri(0:ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - allocate(gfs_phy_tracer%cpi(0:ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - allocate(gfs_phy_tracer%fscav(ntrac), stat=status) - if( status /= 0 ) then - print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me - return - endif - -!--- fill in met tracers - gfs_phy_tracer%vname(1) = 'spfh' - if(ntcw > 0) gfs_phy_tracer%vname(ntcw) = 'clwmr' - if(ntiw > 0) gfs_phy_tracer%vname(ntiw) = 'climr' - if(ntlnc > 0) gfs_phy_tracer%vname(ntlnc) = 'lnc' - if(ntinc > 0) gfs_phy_tracer%vname(ntinc) = 'inc' - if(ntrw > 0) gfs_phy_tracer%vname(ntrw) = 'rnmr' - if(ntsw > 0) gfs_phy_tracer%vname(ntsw) = 'snwmr' - if(ntrnc > 0) gfs_phy_tracer%vname(ntrnc) = 'rnc' - if(ntsnc > 0) gfs_phy_tracer%vname(ntsnc) = 'snc' - if(ntke > 0) gfs_phy_tracer%vname(ntke) = 'tke' -#ifdef MULTI_GASES - print *,' ++++ ntoz nto nto2 ',ntoz,nto,nto2 - if(ntoz > 0) gfs_phy_tracer%vname(ntoz) = 'spo3' - if(nto > 0) gfs_phy_tracer%vname(nto) = 'spo' - if(nto2 > 0) gfs_phy_tracer%vname(nto2) = 'spo2' -#else - if(ntoz > 0) gfs_phy_tracer%vname(ntoz) = 'o3mr' - if(nto > 0) gfs_phy_tracer%vname(nto) = 'o' - if(nto2 > 0) gfs_phy_tracer%vname(nto2) = 'o2' -#endif - - - gfs_phy_tracer%fscav(1:gfs_phy_tracer%ntrac_met) = 0. - -!--- fill in chem tracers - if ( gfs_phy_tracer%ntrac_chem > 0 ) then - do i = 1,gfs_phy_tracer%ntrac_chem - j = i + gfs_phy_tracer%ntrac_met - rgname = trim(gfs_phy_tracer%chem_name(i)) - if(me==0)print *, 'LU_TRC_phy: vname=',j,rgname - gfs_phy_tracer%vname(j) = rgname - enddo - endif - - endif !! - - return - - end subroutine tracer_config_init -! ------------------------------------------------------------------- -! ------------------------------------------------------------------- - function trcindx( specname, tracer ) - implicit none - - character*(*), intent(in) :: specname - type (gfs_phy_tracer_type), intent(in) :: tracer - - character*10 :: name1, name2 - integer :: i, trcindx - -! -- set default value - trcindx = -999 - -! -- convert specname to upper case - call fixchar(specname, name1, 1) - do i = 1, tracer%ntrac - call fixchar(tracer%vname(i), name2, 1) - if( name1 == name2 ) then - trcindx = i - exit - endif - enddo - - return - end function trcindx - -! ------------------------------------------------------------------- - subroutine fixchar(name_in, name_out, option) - implicit none - - character*(*), intent(in) :: name_in - character*(*), intent(out) :: name_out - integer, intent(in) :: option - - character*10 :: temp - integer :: i, ic - - name_out= ' ' - temp = trim(adjustl(name_in)) - do i = 1, len_trim(temp) - ic = IACHAR(temp(i:i)) - if(option == 1 ) then !<--- convert to upper case - if(ic .ge. 97 .and. ic .le. 122) then - name_out(i:i) = CHAR( IC-32 ) - else - name_out(i:i) = temp(i:i) - endif - endif - if(option == 2 ) then !<--- convert to lower case - if(ic .ge. 65 .and. ic .le. 90) then - name_out(i:i) = CHAR( IC+32 ) - else - name_out(i:i) = temp(i:i) - endif - endif - - enddo - name_out = trim(name_out) - return - - end subroutine fixchar - -! ========================================================================= - - end module gfs_phy_tracer_config diff --git a/physics/gocart_tracer_config_stub.f b/physics/gocart_tracer_config_stub.f deleted file mode 100644 index d6df297c7..000000000 --- a/physics/gocart_tracer_config_stub.f +++ /dev/null @@ -1,17 +0,0 @@ -! -!! ! Subroutine : gocart_tracer_config -! -! ! Description: stub for resetting gfs phys when gocart is running -! -! ! Revision history: -! Aug 09 2011 Jun Wang, initial code -! ------------------------------------------------------------------------- -! - subroutine gocart_tracer_config() -! - -! print *,'TRAC_CONFIG: gocart is not running.' - - return - - end subroutine gocart_tracer_config diff --git a/physics/machine.F b/physics/hooks/machine.F similarity index 100% rename from physics/machine.F rename to physics/hooks/machine.F diff --git a/physics/machine.meta b/physics/hooks/machine.meta similarity index 100% rename from physics/machine.meta rename to physics/hooks/machine.meta diff --git a/physics/physcons.F90 b/physics/hooks/physcons.F90 similarity index 99% rename from physics/physcons.F90 rename to physics/hooks/physcons.F90 index 19a03ef20..4d86301e2 100644 --- a/physics/physcons.F90 +++ b/physics/hooks/physcons.F90 @@ -33,7 +33,7 @@ !> This module contains some of the most frequently used math and physics !! constants for GCM models. - module physcons + module physcons ! use machine, only: kind_phys, kind_dyn ! @@ -44,7 +44,7 @@ module physcons !> \name Math constants ! real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 !< pi real(kind=kind_phys),parameter:: con_pi =4.0d0*atan(1.0d0) !< pi - real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys !< square root of 2 + real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0_kind_phys !< square root of 2 real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0_kind_phys !< quare root of 3 !> \name Geophysics/Astronomy constants diff --git a/physics/module_nst_model.f90 b/physics/module_nst_model.f90 deleted file mode 100644 index 980035fe6..000000000 --- a/physics/module_nst_model.f90 +++ /dev/null @@ -1,971 +0,0 @@ -!>\file module_nst_model.f90 -!! This file contains the diurnal thermocline layer model (DTM) of -!! the GFS NSST scheme. - -!>\defgroup dtm_module GFS NSST Diurnal Thermocline Model -!> This module contains the diurnal thermocline layer model (DTM) of -!! the GFS NSST scheme. -!>\ingroup gfs_nst_main_mod - -!> This module contains the diurnal thermocline layer model (DTM) of -!! the GFS NSST scheme. -module nst_module - -! -! the module of diurnal thermocline layer model -! - use machine , only : kind_phys - use module_nst_parameters, only: z_w_max,z_w_min,z_w_ini,eps_z_w,eps_conv, & - eps_sfs,niter_z_w,niter_conv,niter_sfs,ri_c, & - ri_g,omg_m,omg_sh, kw => tc_w,visw,t0k,cp_w, & - z_c_max,z_c_ini,ustar_a_min,delz,exp_const, & - rad2deg,const_rot,tw_max,sst_max - use module_nst_water_prop, only: sw_rad_skin,sw_ps_9b,sw_ps_9b_aw - implicit none - - contains - -!>\ingroup gfs_nst_main_mod -!! This subroutine contains the module of diurnal thermocline layer model. - subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & - alpha,beta,alon,sinlat,soltim,grav,le,d_conv, & - xt,xs,xu,xv,xz,xzts,xtts) - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& - hl_ts,rho,alpha,beta,alon,sinlat,soltim,& - grav,le,d_conv - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts -! local variables - -! -! input variables -! -! timestep: integration time step in seconds -! rich : critical ri (flow dependent) -! tox : x wind stress (n*m^-2 or kg/m/s^2) -! toy : y wind stress (n*m^-2 or kg/m/s^2) -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes -! hl_ts : d(hl)/d(ts) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! sinlat : sine (lat) -! grav : gravity accelleration -! le : le=(2.501-.00237*tsea)*1e6 -! d-conv : fcl thickness -! -! inout variables -! -! xt : dtl heat content (m*k) -! xs : dtl salinity content (m*ppt) -! xu : dtl x current content (m*m/s) -! xv : dtl y current content (m*m/s) -! xz : dtl thickness (m) -! xzts : d(xz)/d(ts) (m/k ) -! xtts : d(xt)/d(ts) (m) -! -! logical lprnt - -! if (lprnt) print *,' first xt=',xt - if ( xt <= 0.0 ) then ! dtl doesn't exist yet - call dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,& - beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) - elseif ( xt > 0.0 ) then ! dtl already exists -! -! forward the system one time step -! - call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & - beta,alon,sinlat,soltim,grav,le,d_conv, & - xt,xs,xu,xv,xz,xzts,xtts) - endif ! if ( xt == 0 ) then - - end subroutine dtm_1p - -!>\ingroup gfs_nst_main_mod -!! This subroutine integrates one time step with modified Euler method. - subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,& - beta,alon,sinlat,soltim,grav,le,d_conv, & - xt,xs,xu,xv,xz,xzts,xtts) - -! -! subroutine eulerm: integrate one time step with modified euler method -! - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& - hl_ts,rho,alpha,beta,alon,sinlat,soltim,& - grav,le,d_conv - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts -! local variables - real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0 - real(kind=kind_phys) :: fw,aw,q_warm - real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1,xzts1,xtts1 - real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2 - real(kind=kind_phys) :: dzw,drho,fc - real(kind=kind_phys) :: alat,speed -! logical lprnt - -! -! input variables -! -! timestep: integration time step in seconds -! rich : critial ri (flow/mass dependent) -! tox : x wind stress (n*m^-2 or kg/m/s^2) -! toy : y wind stress (n*m^-2 or kg/m/s^2) -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes -! hl_ts : d(hl)/d(ts) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! alon : longitude (deg) -! sinlat : sine (lat) -! soltim : solar time -! grav : gravity accelleration -! le : le=(2.501-.00237*tsea)*1e6 -! d_conv : fcl thickness (m) -! -! inout variables -! -! xt : dtl heat content (m*k) -! xs : dtl salinity content (m*ppt) -! xu : dtl x current content (m*m/s) -! xv : dtl y current content (m*m/s) -! xz : dtl thickness (m) -! xzts : d(xz)/d(ts) (m/k ) -! xtts : d(xt)/d(ts) (m) - - xt0 = xt - xs0 = xs - xu0 = xu - xv0 = xv - xz0 = xz - xtts0 = xtts - xzts0 = xzts - speed = max(1.0e-8, xu0*xu0+xv0*xv0) - - alat = asin(sinlat)*rad2deg - - fc = const_rot*sinlat - - call sw_ps_9b(xz0,fw) - - q_warm = fw*i0-q !total heat abs in warm layer - - call sw_ps_9b_aw(xz0,aw) - - drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep - -! dzw = xz0*(tox*xu0+toy*xv0) / (rho*(xu0*xu0+xv0*xv0)) & -! + xz0*xz0*xz0*drho*grav / (4.0*rich*(xu0*xu0+xv0*xv0)) - dzw = xz0 * ((tox*xu0+toy*xv0) / (rho*speed) & - + xz0*xz0*drho*grav / (4.0*rich*speed)) - - xt1 = xt0 + timestep*q_warm/(rho*cp_w) - xs1 = xs0 + timestep*sep - xu1 = xu0 + timestep*(fc*xv0+tox/rho) - xv1 = xv0 + timestep*(-fc*xu0+toy/rho) - xz1 = xz0 + timestep*dzw - -! if (lprnt) print *,' xt1=',xt1,' xz1=',xz1,' xz0=',xz0,' dzw=',dzw, & -! 'timestep=',timestep,tox,toy,xu0,xv0,rho,drho,grav,rich - - if ( xt1 <= 0.0 .or. xz1 <= 0.0 .or. xz1 > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - return - endif - -! call dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt1,xs1,xu1,xv1,xz1,tr_mda,tr_fca,tr_tla,tr_mwa) - - xzts1 = xzts0 + timestep*((1.0/(xu0*xu0+xv0*xv0)) * & - ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz0**3/(4.0*rich*rho)& - +( (tox*xu0+toy*xv0)/rho+(3.0*drho-alpha*i0*aw*xz0/(rho*cp_w)) & - *grav*xz0*xz0/(4.0*rich) )*xzts0 )) - xtts1 = xtts0 + timestep*(i0*aw*xzts0-q_ts)/(rho*cp_w) - -! if ( 2.0*xt1/xz1 > 0.001 ) then -! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_01 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& -! 2.0*xt1/xz1,2.0*xs1/xz1,2.0*xu1/xz1,2.0*xv1/xz1,xz1,xtts1,xzts1,d_conv,t_fcl,te -! endif - - call sw_ps_9b(xz1,fw) - q_warm = fw*i0-q !total heat abs in warm layer - call sw_ps_9b_aw(xz1,aw) - drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep - dzw = xz1*(tox*xu1+toy*xv1) / (rho*(xu1*xu1+xv1*xv1)) & - + xz1*xz1*xz1*drho*grav / (4.0*rich*(xu1*xu1+xv1*xv1)) - - xt2 = xt0 + timestep*q_warm/(rho*cp_w) - xs2 = xs0 + timestep*sep - xu2 = xu0 + timestep*(fc*xv1+tox/rho) - xv2 = xv0 + timestep*(-fc*xu1+toy/rho) - xz2 = xz0 + timestep*dzw - -! if (lprnt) print *,' xt2=',xt2,' xz2=',xz2 - - if ( xt2 <= 0.0 .or. xz2 <= 0.0 .or. xz2 > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - return - endif - - xzts2 = xzts0 + timestep*((1.0/(xu1*xu1+xv1*xv1)) * & - ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz1**3/(4.0*rich*rho)& - +( (tox*xu1+toy*xv1)/rho+(3.0*drho-alpha*i0*aw*xz1/(rho*cp_w))* & - grav*xz1*xz1/(4.0*rich) )*xzts1 )) - xtts2 = xtts0 + timestep*(i0*aw*xzts1-q_ts)/(rho*cp_w) - - xt = 0.5*(xt1 + xt2) - xs = 0.5*(xs1 + xs2) - xu = 0.5*(xu1 + xu2) - xv = 0.5*(xv1 + xv2) - xz = 0.5*(xz1 + xz2) - xzts = 0.5*(xzts1 + xzts2) - xtts = 0.5*(xtts1 + xtts2) - - if ( xt <= 0.0 .or. xz < 0.0 .or. xz > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - endif - -! if (lprnt) print *,' xt=',xt,' xz=',xz -! if ( 2.0*xt/xz > 0.001 ) then -! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_02 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& -! 2.0*xt/xz,2.0*xs/xz,2.0*xu/xz,2.0*xv/xz,xz,xtts,xzts,d_conv,t_fcl,te -! endif - return - - end subroutine eulerm - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies xz adjustment. - subroutine dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt,xs,xu,xv,xz,tr_mda,tr_fca,tr_tla,tr_mwa) -! apply xz adjustment: minimum depth adjustment (mda) -! free convection adjustment (fca); -! top layer adjustment (tla); -! maximum warming adjustment (mwa) -! - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,i0,q,rho,d_conv - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz - real(kind=kind_phys), intent(out) :: tr_mda,tr_fca,tr_tla,tr_mwa -! local variables - real(kind=kind_phys) :: dz,t0,ttop0,ttop,fw,q_warm - real(kind=kind_phys) :: xz_fca,xz_tla,xz_mwa -! - real(kind=kind_phys) xz_mda - - tr_mda = 0.0; tr_fca = 0.0; tr_tla = 0.0; tr_mwa = 0.0 - -! apply mda - if ( z_w_min > xz ) then - xz_mda = z_w_min - endif -! apply fca - if ( d_conv > 0.0 ) then - xz_fca = 2.0*xt/((2.0*xt/xz)*(1.0-d_conv/(2.0*xz))) - tr_fca = 1.0 - if ( xz_fca >= z_w_max ) then - call dtl_reset_cv(xt,xs,xu,xv,xz) - go to 10 - endif - endif -! apply tla - dz = min(xz,max(d_conv,delz)) - call sw_ps_9b(dz,fw) - q_warm=fw*i0-q !total heat abs in warm layer - - if ( q_warm > 0.0 ) then - call cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop0) -! ttop = (2.0*xt/xz)*(1.0-dz/(2.0*xz)) - ttop = ((xt+xt)/xz)*(1.0-dz/(xz+xz)) - if ( ttop > ttop0 ) then - xz_tla = (xt+sqrt(xt*(xt-delz*ttop0)))/ttop0 - tr_tla = 1.0 - if ( xz_tla >= z_w_max ) then - call dtl_reset_cv(xt,xs,xu,xv,xz) - go to 10 - endif - endif - endif - -! apply mwa - t0 = 2.0*xt/xz - if ( t0 > tw_max ) then - if ( xz >= z_w_max ) then - call dtl_reset_cv(xt,xs,xu,xv,xz) - go to 10 - endif - endif - - xz = max(xz_mda,xz_fca,xz_tla,xz_mwa) - - 10 continue - - end subroutine dtm_1p_zwa - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies free convection adjustment(fca). - subroutine dtm_1p_fca(d_conv,xt,xtts,xz,xzts) - -! apply xz adjustment: free convection adjustment (fca); -! - real(kind=kind_phys), intent(in) :: d_conv,xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) :: t_fcl,t0 -! - t0 = 2.0*xt/xz - t_fcl = t0*(1.0-d_conv/(2.0*xz)) - xz = 2.0*xt/t_fcl -! xzts = 2.0*xtts/t_fcl - - end subroutine dtm_1p_fca - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies top layer adjustment (tla). - subroutine dtm_1p_tla(dz,te,xt,xtts,xz,xzts) - -! apply xz adjustment: top layer adjustment (tla); -! - real(kind=kind_phys), intent(in) :: dz,te,xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) tem -! - tem = xt*(xt-dz*te) - if (tem > 0.0) then - xz = (xt+sqrt(xt*(xt-dz*te)))/te - else - xz = z_w_max - endif -! xzts = xtts*(1.0+0.5*(2.0*xt-dz*te)/sqrt(xt*(xt-dz*te)))/te - end subroutine dtm_1p_tla - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies maximum warming adjustment (mwa). - subroutine dtm_1p_mwa(xt,xtts,xz,xzts) - -! apply xz adjustment: maximum warming adjustment (mwa) -! - real(kind=kind_phys), intent(in) :: xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables -! - xz = 2.0*xt/tw_max -! xzts = 2.0*xtts/tw_max - end subroutine dtm_1p_mwa - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies minimum depth adjustment (xz adjustment). - subroutine dtm_1p_mda(xt,xtts,xz,xzts) - -! apply xz adjustment: minimum depth adjustment (mda) -! - real(kind=kind_phys), intent(in) :: xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) :: ta -! - xz = max(z_w_min,xz) - ta = 2.0*xt/xz -! xzts = 2.0*xtts/ta - - end subroutine dtm_1p_mda - -!>\ingroup gfs_nst_main_mod -!! This subroutine applies maximum temperature adjustment (mta). - subroutine dtm_1p_mta(dta,xt,xtts,xz,xzts) - -! apply xz adjustment: maximum temperature adjustment (mta) -! - real(kind=kind_phys), intent(in) :: dta,xt,xtts - real(kind=kind_phys), intent(inout) :: xz,xzts -! local variables - real(kind=kind_phys) :: ta -! - ta = max(0.0,2.0*xt/xz-dta) - if ( ta > 0.0 ) then - xz = 2.0*xt/ta - else - xz = z_w_max - endif -! xzts = 2.0*xtts/ta - - end subroutine dtm_1p_mta - -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates depth for convective adjustment. -subroutine convdepth(kdt,timestep,i0,q,sss,sep,rho,alpha,beta,xt,xs,xz,d_conv) - -! -! calculate depth for convective adjustment -! - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,i0,q,sss,sep,rho,alpha,beta - real(kind=kind_phys), intent(in) :: xt,xs,xz - real(kind=kind_phys), intent(out) :: d_conv - real(kind=kind_phys) :: t,s,d_conv_ini,d_conv2,fxp,aw,s1,s2,fac1 - integer :: n -! -! input variables -! -! timestep: time step in seconds -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! xt : initial heat content (k*m) -! xs : initial salinity content (ppt*m) -! xz : initial dtl thickness (m) -! -! output variables -! -! d_conv : free convection depth (m) - -! t : initial diurnal warming t (k) -! s : initial diurnal warming s (ppt) - - n = 0 - t = 2.0*xt/xz - s = 2.0*xs/xz - - s1 = alpha*rho*t-omg_m*beta*rho*s - - if ( s1 == 0.0 ) then - d_conv = 0.0 - else - - fac1 = alpha*q/cp_w+omg_m*beta*rho*sep - if ( i0 <= 0.0 ) then - d_conv2=(2.0*xz*timestep/s1)*fac1 - if ( d_conv2 > 0.0 ) then - d_conv = sqrt(d_conv2) - else - d_conv = 0.0 - endif - elseif ( i0 > 0.0 ) then - - d_conv_ini = 0.0 - - iter_conv: do n = 1, niter_conv - call sw_ps_9b(d_conv_ini,fxp) - call sw_ps_9b_aw(d_conv_ini,aw) - s2 = alpha*(q-(fxp-aw*d_conv_ini)*i0)/cp_w+omg_m*beta*rho*sep - d_conv2=(2.0*xz*timestep/s1)*s2 - if ( d_conv2 < 0.0 ) then - d_conv = 0.0 - exit iter_conv - endif - d_conv = sqrt(d_conv2) - if ( abs(d_conv-d_conv_ini) < eps_conv .and. n <= niter_conv ) exit iter_conv - d_conv_ini = d_conv - enddo iter_conv - d_conv = max(0.0,min(d_conv,z_w_max)) - endif ! if ( i0 <= 0.0 ) then - - endif ! if ( s1 == 0.0 ) then - -! if ( d_conv > 0.01 ) then -! write(*,'(a,i4,i3,10f9.3,3f10.6,f10.1,f6.2)') ' d_conv : ',kdt,n,d_conv,d_conv_ini,q,i0,rho,cp_w,timestep,xt,xs,xz,sep, & -! s1,s2,d_conv2,aw -! endif - - end subroutine convdepth - -!>\ingroup gfs_nst_main_mod - subroutine dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & - alpha,beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) -! -! determine xz iteratively (starting wit fw = 0.5) and then update the other 6 variables -! - - integer,intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& - hl_ts,rho,alpha,beta,alon,sinlat,soltim,grav,le - real(kind=kind_phys), intent(out) :: xt,xs,xu,xv,xz,xzts,xtts - real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0 - real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1 - real(kind=kind_phys) :: fw,aw,q_warm,ft0,fs0,fu0,fv0,fz0,ft1,fs1,fu1,fv1,fz1 - real(kind=kind_phys) :: coeff1,coeff2,ftime,z_w,z_w_tmp,fc,warml,alat - integer :: n -! -! input variables -! -! timestep: time step in seconds -! tox : x wind stress (n*m^-2 or kg/m/s^2) -! toy : y wind stress (n*m^-2 or kg/m/s^2) -! i0 : solar radiation flux at the surface (wm^-2) -! q : non-solar heat flux at the surface (wm^-2) -! sss : salinity (ppt) -! sep : sr(e-p) (ppt*m/s) -! rho : sea water density (kg*m^-3) -! alpha : thermal expansion coefficient (1/k) -! beta : saline contraction coefficient (1/ppt) -! alon : longitude -! sinlat : sine(latitude) -! grav : gravity accelleration -! le : le=(2.501-.00237*tsea)*1e6 -! -! output variables -! -! xt : onset t content in dtl -! xs : onset s content in dtl -! xu : onset u content in dtl -! xv : onset v content in dtl -! xz : onset dtl thickness (m) -! xzts : onset d(xz)/d(ts) (m/k ) -! xtts : onset d(xt)/d(ts) (m) - - fc=1.46/10000.0/2.0*sinlat - alat = asin(sinlat) -! -! initializing dtl (just before the onset) -! - xt0 = 0.0 - xs0 = 0.0 - xu0 = 0.0 - xv0 = 0.0 - - z_w_tmp=z_w_ini - - call sw_ps_9b(z_w_tmp,fw) -! fw=0.5 ! - q_warm=fw*i0-q !total heat abs in warm layer - - if ( abs(alat) > 1.0 ) then - ftime=sqrt((2.0-2.0*cos(fc*timestep))/(fc*fc*timestep)) - else - ftime=timestep - endif - - coeff1=alpha*grav/cp_w - coeff2=omg_m*beta*grav*rho - warml = coeff1*q_warm-coeff2*sep - - if ( warml > 0.0 .and. q_warm > 0.0) then - iters_z_w: do n = 1,niter_z_w - if ( warml > 0.0 .and. q_warm > 0.0 ) then - z_w=sqrt(2.0*rich*ftime/rho)*sqrt(tox**2+toy**2)/sqrt(warml) - else - z_w = z_w_max - exit iters_z_w - endif - -! write(*,'(a,i4,i4,10f9.3,f9.6,f3.0)') ' z_w = ',kdt,n,z_w,z_w_tmp,timestep,q_warm,q,i0,fw,tox,toy,sep,warml,omg_m - - if (abs(z_w - z_w_tmp) < eps_z_w .and. z_w/=z_w_max .and. n < niter_z_w) exit iters_z_w - z_w_tmp=z_w - call sw_ps_9b(z_w_tmp,fw) - q_warm = fw*i0-q - warml = coeff1*q_warm-coeff2*sep - end do iters_z_w - else - z_w=z_w_max - endif - - xz0 = max(z_w,z_w_min) - -! -! update xt, xs, xu, xv -! - if ( z_w < z_w_max .and. q_warm > 0.0) then - - call sw_ps_9b(z_w,fw) - q_warm=fw*i0-q !total heat abs in warm layer - - ft0 = q_warm/(rho*cp_w) - fs0 = sep - fu0 = fc*xv0+tox/rho - fv0 = -fc*xu0+toy/rho - - xt1 = xt0 + timestep*ft0 - xs1 = xs0 + timestep*fs0 - xu1 = xu0 + timestep*fu0 - xv1 = xv0 + timestep*fv0 - - fz0 = xz0*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz0*xz0/(4.0*rich) & - -alpha*grav*q_warm*xz0*xz0/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) - xz1 = xz0 + timestep*fz0 - - xz1 = max(xz1,z_w_min) - - if ( xt1 < 0.0 .or. xz1 > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) - return - endif - - call sw_ps_9b(xz1,fw) - q_warm=fw*i0-q !total heat abs in warm layer - - ft1 = q_warm/(rho*cp_w) - fs1 = sep - fu1 = fc*xv1+tox/rho - fv1 = -fc*xu1+toy/rho - - fz1 = xz1*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz1*xz1/(4.0*rich) & - -alpha*grav*q_warm*xz1*xz1/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) - - xt = xt0 + 0.5*timestep*(ft0+ft1) - xs = xs0 + 0.5*timestep*(fs0+fs1) - xu = xu0 + 0.5*timestep*(fu0+fu1) - xv = xv0 + 0.5*timestep*(fv0+fv1) - xz = xz0 + 0.5*timestep*(fz0+fz1) - - xz = max(xz,z_w_min) - - call sw_ps_9b_aw(xz,aw) - -! xzts = (q_ts+(cp_w*omg_m*beta*sss/(le*alpha))*hl_ts)*xz/(i0*xz*aw+2.0*q_warm-2.0*(rho*cp_w*omg_m*beta*sss/alpha)*(sep/sss)) - xzts = (q_ts+omg_m*rho*cp_w*beta*sss*hl_ts*xz/(le*alpha))/(i0*xz*aw+2.0*q_warm-2.0*omg_m*rho*cp_w*beta*sss*sep/(le*alpha)) - xtts = timestep*(i0*aw*xzts-q_ts)/(rho*cp_w) - endif - - if ( xt < 0.0 .or. xz > z_w_max ) then - call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) - endif - - return - - end subroutine dtm_onset - -!>\ingroup gfs_nst_main_mod -!! This subroutine computes coefficients (\a w_0 and \a w_d) to -!! calculate d(tw)/d(ts). - subroutine cal_w(kdt,xz,xt,xzts,xtts,w_0,w_d) -! -! abstract: calculate w_0,w_d -! -! input variables -! -! kdt : the number of time step -! xt : dtl heat content -! xz : dtl depth -! xzts : d(zw)/d(ts) -! xtts : d(xt)/d(ts) -! -! output variables -! -! w_0 : coefficint 1 to calculate d(tw)/d(ts) -! w_d : coefficint 2 to calculate d(tw)/d(ts) - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: xz,xt,xzts,xtts - real(kind=kind_phys), intent(out) :: w_0,w_d - - w_0 = 2.0*(xtts-xt*xzts/xz)/xz - w_d = (2.0*xt*xzts/xz**2-w_0)/xz - -! if ( 2.0*xt/xz > 1.0 ) then -! write(*,'(a,i4,2f9.3,4f10.4))') ' cal_w : ',kdt,xz,xt,w_0,w_d,xzts,xtts -! endif - end subroutine cal_w - -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates the diurnal warming amount at the top layer -!! with thickness of \a delz. - subroutine cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop) -! -! abstract: calculate -! -! input variables -! -! kdt : the number of record -! timestep : the number of record -! q_warm : total heat abs in layer dz -! rho : sea water density -! dz : dz = max(delz,d_conv) top layer thickness defined to adjust xz -! xt : heat content in dtl at previous time -! xz : dtl thickness at previous time -! -! output variables -! -! ttop : the diurnal warming amount at the top layer with thickness of delz - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: timestep,q_warm,rho,dz,xt,xz - real(kind=kind_phys), intent(out) :: ttop - real(kind=kind_phys) :: dt_warm,t0 - - dt_warm = (xt+xt)/xz - t0 = dt_warm*(1.0-dz/(xz+xz)) - ttop = t0 + q_warm*timestep/(rho*cp_w*dz) - - end subroutine cal_ttop - -!>\ingroup gfs_nst_main_mod -!! This subroutine adjust dtm-1p dtl thickness by applying shear flow stability -!! with assumed exponential profile. - subroutine app_sfs(kdt,xt,xs,xu,xv,alpha,beta,grav,d_1p,xz) -! -! abstract: adjust dtm-1p dtl thickness by applying shear flow stability with assumed exponetial profile -! -! input variables -! -! kdt : the number of record -! xt : heat content in dtl -! xs : salinity content in dtl -! xu : u-current content in dtl -! xv : v-current content in dtl -! alpha -! beta -! grav -! d_1p : dtl depth before sfs applied -! -! output variables -! -! xz : dtl depth - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: xt,xs,xu,xv,alpha,beta,grav,d_1p - real(kind=kind_phys), intent(out) :: xz -! real(kind=kind_phys) :: ze,cc,xz0,l,d_sfs, t_sfs, tem - real(kind=kind_phys) :: cc,l,d_sfs,tem - real(kind=kind_phys), parameter :: c2 = 0.3782 - integer :: n - - cc = ri_g/(grav*c2) - - tem = alpha*xt - beta*xs - if (tem > 0.0) then - d_sfs = sqrt(2.0*cc*(xu*xu+xv*xv)/tem) - else - d_sfs = 0.0 - endif - -! xz0 = d_1p -! iter_sfs: do n = 1, niter_sfs -! l = int_epn(0.0,xz0,0.0,xz0,2) -! d_sfs = cc*(xu*xu+xv*xv)/((alpha*xt-beta*xs)*l) -! write(*,'(a,i6,i3,4f9.4))') ' app_sfs_iter : ',kdt,n,cc,l,xz0,d_sfs -! if ( abs(d_sfs-xz0) < eps_sfs .and. n <= niter_sfs ) exit iter_sfs -! xz0 = d_sfs -! enddo iter_sfs - -! ze = a2*d_sfs ! not used! - - l = int_epn(0.0,d_sfs,0.0,d_sfs,2) - -! t_sfs = xt/l -! xz = (xt+xt) / t_sfs - - xz = l + l - -! write(*,'(a,i6,6f9.4))') ' app_sfs : ',kdt,xz0,d_sfs,d_1p,xz,2.0*xt/d_1p,t_sfs - end subroutine app_sfs - -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates d(tz)/d(ts). - subroutine cal_tztr(kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr) -! -! abstract: calculate d(tz)/d(ts) -! -! input variables -! -! kdt : the number of record -! xt : heat content in dtl -! xz : dtl depth (m) -! c_0 : coefficint 1 to calculate d(tc)/d(ts) -! c_d : coefficint 2 to calculate d(tc)/d(ts) -! w_0 : coefficint 1 to calculate d(tw)/d(ts) -! w_d : coefficint 2 to calculate d(tw)/d(ts) -! -! output variables -! -! tztr : d(tz)/d(tr) - - integer, intent(in) :: kdt - real(kind=kind_phys), intent(in) :: xt,c_0,c_d,w_0,w_d,zc,zw,z - real(kind=kind_phys), intent(out) :: tztr - - if ( xt > 0.0 ) then - if ( z <= zc ) then -! tztr = 1.0/(1.0-w_0+c_0)+z*(w_d-c_d)/(1.0-w_0+c_0) - tztr = (1.0+z*(w_d-c_d))/(1.0-w_0+c_0) - elseif ( z > zc .and. z < zw ) then -! tztr = (1.0+c_0)/(1.0-w_0+c_0)+z*w_d/(1.0-w_0+c_0) - tztr = (1.0+c_0+z*w_d)/(1.0-w_0+c_0) - elseif ( z >= zw ) then - tztr = 1.0 - endif - elseif ( xt == 0.0 ) then - if ( z <= zc ) then -! tztr = 1.0/(1.0+c_0)-z*c_d/(1.0+c_0) - tztr = (1.0-z*c_d)/(1.0+c_0) - else - tztr = 1.0 - endif - else - tztr = 1.0 - endif - -! write(*,'(a,i4,9f9.4))') ' cal_tztr : ',kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr - end subroutine cal_tztr - -!>\ingroup gfs_nst_main_mod -!> This subroutine contains the upper ocean cool-skin parameterization -!! (Fairall et al, 1996 \cite fairall_et_al_1996). -subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le,deltat_c,z_c,c_0,c_d) -! -! upper ocean cool-skin parameterizaion, fairall et al, 1996. -! -! input: -! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s) -! f_nsol : the "nonsolar" part of the surface heat flux (w/m^s) -! f_sol_0 : solar radiation at the ocean surface (w/m^2) -! evap : latent heat flux (w/m^2) -! sss : ocean upper mixed layer salinity (ppu) -! alpha : thermal expansion coefficient -! beta : saline contraction coefficient -! rho_w : oceanic density -! rho_a : atmospheric density -! ts : oceanic surface temperature -! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes -! hl_ts : d(hl)/d(ts) -! grav : gravity -! le : -! -! output: -! deltat_c: cool-skin temperature correction (degrees k) -! z_c : molecular sublayer (cool-skin) thickness (m) -! c_0 : coefficient1 to calculate d(tz)/d(ts) -! c_d : coefficient2 to calculate d(tz)/d(ts) - -! - real(kind=kind_phys), intent(in) :: ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le - real(kind=kind_phys), intent(out):: deltat_c,z_c,c_0,c_d -! declare local variables - real(kind=kind_phys), parameter :: a1=0.065, a2=11.0, a3=6.6e-5, a4=8.0e-4, tcw=0.6 & - , tcwi=1.0/tcw - real(kind=kind_phys) :: a_c,b_c,zc_ts,bc1,bc2 - real(kind=kind_phys) :: xi,hb,ustar1_a,bigc,deltaf,fxp - real(kind=kind_phys) :: zcsq - real(kind=kind_phys) :: cc1,cc2,cc3 - - - z_c = z_c_ini ! initial guess - - ustar1_a = max(ustar_a,ustar_a_min) - - call sw_rad_skin(z_c,fxp) - deltaf = f_sol_0*fxp - - hb = alpha*(f_nsol-deltaf)+beta*sss*cp_w*evap/le - bigc = 16*grav*cp_w*(rho_w*visw)**3/(rho_a*rho_a*kw*kw) - - if ( hb > 0 ) then - xi = 6./(1+(bigc*hb/ustar1_a**4)**0.75)**0.3333333 - else - xi = 6.0 - endif - z_c = min(z_c_max,xi*visw/(sqrt(rho_a/rho_w)*ustar1_a )) - - call sw_rad_skin(z_c,fxp) - - deltaf = f_sol_0*fxp - deltaf = f_nsol - deltaf - if ( deltaf > 0 ) then - deltat_c = deltaf * z_c / kw - else - deltat_c = 0. - z_c = 0. - endif -! -! calculate c_0 & c_d -! - if ( z_c > 0.0 ) then - cc1 = 6.0*visw / (tcw*ustar1_a*sqrt(rho_a/rho_w)) - cc2 = bigc*alpha / max(ustar_a,ustar_a_min)**4 - cc3 = beta*sss*cp_w/(alpha*le) - zcsq = z_c * z_c - a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4) - - if ( hb > 0.0 .and. zcsq > 0.0 .and. alpha > 0.0) then - bc1 = zcsq * (q_ts+cc3*hl_ts) - bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq) - zc_ts = bc1/bc2 -! b_c = z_c**2*(q_ts+cc3*hl_ts)/(z_c**2*f_sol_0*a_c-4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*z_c**2)) ! d(z_c)/d(ts) - b_c = (q_ts+cc3*hl_ts)/(f_sol_0*a_c & - - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq*zcsq)) ! d(z_c)/d(ts) - c_0 = (z_c*q_ts+(f_nsol-deltaf-f_sol_0*a_c*z_c)*b_c)*tcwi - c_d = (f_sol_0*a_c*z_c*b_c-q_ts)*tcwi - - else - b_c = 0.0 - zc_ts = 0.0 - c_0 = z_c*q_ts*tcwi - c_d = -q_ts*tcwi - endif - -! if ( c_0 < 0.0 ) then -! write(*,'(a,2f12.6,10f10.6)') ' c_0, c_d = ',c_0,c_d,b_c,zc_ts,hb,bc1,bc2,z_c,cc1,cc2,cc3,z_c**2 -! endif - -! c_0 = z_c*q_ts/tcw -! c_d = -q_ts/tcw - - else - c_0 = 0.0 - c_d = 0.0 - endif ! if ( z_c > 0.0 ) then - - end subroutine cool_skin -! -!====================== -! -!>\ingroup gfs_nst_main_mod -!! This function calculates a definitive integral of an exponential curve (power of 2). - real function int_epn(z1,z2,zmx,ztr,n) -! -! abstract: calculate a definitive integral of an exponetial curve (power of 2) -! - real(kind_phys) :: z1,z2,zmx,ztr,zi - real(kind_phys) :: fa,fb,fi,int - integer :: m,i,n - - m = nint((z2-z1)/delz) - fa = exp(-exp_const*((z1-zmx)/(ztr-zmx))**n) - fb = exp(-exp_const*((z2-zmx)/(ztr-zmx))**n) - int = 0.0 - do i = 1, m-1 - zi = z1 + delz*float(i) - fi = exp(-exp_const*((zi-zmx)/(ztr-zmx))**n) - int = int + fi - enddo - int_epn = delz*((fa+fb)/2.0 + int) - end function int_epn - -!>\ingroup gfs_nst_main_mod -!! This subroutine resets the value of xt,xs,xu,xv,xz. - subroutine dtl_reset_cv(xt,xs,xu,xv,xz) - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz - xt = 0.0 - xs = 0.0 - xu = 0.0 - xv = 0.0 - xz = z_w_max - end subroutine dtl_reset_cv - -!>\ingroup gfs_nst_main_mod -!! This subroutine resets the value of xt,xs,xu,xv,xz,xtts,xzts. - subroutine dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) - real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts - xt = 0.0 - xs = 0.0 - xu = 0.0 - xv = 0.0 - xz = z_w_max - xtts = 0.0 - xzts = 0.0 - end subroutine dtl_reset - -end module nst_module diff --git a/physics/module_nst_parameters.f90 b/physics/module_nst_parameters.f90 deleted file mode 100644 index ee0a34914..000000000 --- a/physics/module_nst_parameters.f90 +++ /dev/null @@ -1,143 +0,0 @@ -!>\file module_nst_parameters.f90 -!! This file contains constants and paramters used in GFS -!! near surface sea temperature scheme. - -!>\defgroup nst_parameters GFS NSST Parameter Module -!! \ingroup gfs_nst_main_mod -!! This module contains constants and parameters used in GFS -!! near surface sea temperature scheme. -!! history: -!! 20210305: X.Li, reduce z_w_max from 30 m to 20 m -module module_nst_parameters - use machine, only : kind_phys - ! - ! air constants and coefficients from the atmospehric model - use physcons, only: & - eps => con_eps & - ,cp_a => con_cp & !< spec heat air @p (j/kg/k) - , epsm1 => con_epsm1 & - , hvap => con_hvap & !< lat heat h2o cond (j/kg) - ,sigma_r => con_sbc & !< stefan-boltzmann (w/m2/k4) - ,grav => con_g & !< acceleration due to gravity (kg/m/s^2) - ,omega => con_omega & !< ang vel of earth (1/s) - ,rvrdm1 => con_fvirt & - ,rd => con_rd & - ,rocp => con_rocp & !< r/cp - ,pi => con_pi - ! - ! note: take timestep from here later - public - integer :: & - niter_conv = 5, & - niter_z_w = 5, & - niter_sfs = 5 - real (kind=kind_phys), parameter :: & - ! - ! general constants - sec_in_day=86400. & - ,sec_in_hour=3600. & - ,solar_time_6am=21600.0 & - ,const_rot=0.000073 & !< constant to calculate corioli force - ,ri_c=0.65 & - ,ri_g=0.25 & - ,eps_z_w=0.01 & !< criteria to finish iterations for z_w - ,eps_conv=0.01 & !< criteria to finish iterations for d_conv - ,eps_sfs=0.01 & !< criteria to finish iterations for d_sfs - ,z_w_max=20.0 & !< max warm layer thickness - ,z_w_min=0.2 & !< min warm layer thickness - ,z_w_ini=0.2 & !< initial warm layer thickness in dtl_onset - ,z_c_max=0.01 & !< maximum of sub-layer thickness (m) - ,z_c_ini=0.001 & !< initial value of z_c - ,ustar_a_min=0.031 & !< minimum of friction wind speed (m/s): 0.031 ~ 1m/s at 10 m hight - ,tau_min=0.005 & !< minimum of wind stress for dtm - ,exp_const=9.5 & !< coefficient in exponet profile - ,delz=0.1 & !< vertical increment for integral calculation (m) - ,von=0.4 & !< von karman's "constant" - ,t0k=273.16 & !< celsius to kelvin - ,gray=0.97 & - ,sst_max=308.16 & - ,tw_max=5.0 & - ,wd_max=2.0 & - ,omg_m =1.0 & !< trace factor to apply salinity effect - ,omg_rot = 1.0 & !< trace factor to apply rotation effect - ,omg_sh = 1.0 & !< trace factor to apply sensible heat due to rainfall effect - ,visw=1.e-6 & !< m2/s kinematic viscosity water - ,novalue=0 & - ,smallnumber=1.e-6 & - ,timestep_oc=sec_in_day/8. & !< time step in the ocean model (3 hours) - ,radian=2.*pi/180. & - ,rad2deg=180./pi & - ,cp_w=4000. & !< specific heat water (j/kg/k ) - ,rho0_w=1022.0 & !< density water (kg/m3 ) (or 1024.438) - ,vis_w=1.e-6 & !< kinematic viscosity water (m2/s ) - ,tc_w=0.6 & !< thermal conductivity water (w/m/k ) - ,capa_w =3950.0 & !< heat capacity of sea water ! - ,thref =1.0e-3 !< reference value of specific volume (m**3/kg) - -!!$!============================================ -!!$ -!!$ ,lvapor=2.453e6 & ! latent heat of vaporization note: make it function of t ????? note the same as hvap -!!$ ,alpha=1 ! thermal expansion coefficient -!!$ ,beta ! saline contraction coefficient -!!$ ,cp=1 !=1 specific heat of sea water -!!$ ,g=1 ! acceleration due to gravity -!!$ ,kw=1 ! thermal conductivity of water -!!$ ,nu=1 !kinematic wiscosity -!!$ ,rho_w=1 !water density -!!$ ,rho_a=1 !air density -!!$ ,l_vapr=2.453e6 -!!$ ,novalue=--1.0e+10 -!!$ -!!$c factors -!!$ beta=1.2 !given as 1.25 in fairall et al.(1996) -!!$ von=0.4 ! von karman's "constant" -!!$c fdg=1.00 ! fairall's lkb rr to von karman adjustment -!!$ fdg=1.00 !based on results from flux workshop august 1995 -!!$ tok=273.16 ! celsius to kelvin -!!$ twopi=3.14159*2. -!!$ -!!$c air constants and coefficients -!!$ rgas=287.1 !j/kg/k gas const. dry air -!!$ xlv=(2.501-0.00237*ts)*1e+6 !j/kg latent heat of vaporization at ts -!!$ cpa=1004.67 !j/kg/k specific heat of dry air (businger 1982) -!!$ cpv=cpa*(1+0.84*q) !moist air - currently not used (businger 1982) -!!$ rhoa=p*100./(rgas*(t+tok)*(1.+.61*q)) !kg/m3 moist air density ( " ) -!!$ visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) !m2/s -!!$ !kinematic viscosity of dry air - andreas (1989) crrel rep. 89-11 -!!$c -!!$c cool skin constants -!!$ al=2.1e-5*(ts+3.2)**0.79 !water thermal expansion coefft. -!!$ be=0.026 !salinity expansion coefft. -!!$ cpw=4000. !j/kg/k specific heat water -!!$ rhow=1022. !kg/m3 density water -!!$ visw=1.e-6 !m2/s kinematic viscosity water -!!$ tcw=0.6 !w/m/k thermal conductivity water -!!$ bigc=16.*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) -!!$ wetc=0.622*xlv*qs/(rgas*(ts+tok)**2) !correction for dq;slope of sat. vap. -!!$ -!!$! -!!$! functions -!!$ -!!$ -!!$ real, parameter :: timestep=86400. !integration time step, second -!!$ -!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 -!!$ real, parameter :: capa =3950.0 !heat capacity of sea water -!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 -!!$ real , parameter :: hslab=50.0 !slab ocean depth -!!$ real , parameter :: bad=-1.0e+10 -!!$ real , parameter :: tmin=2.68e+02 -!!$ real , parameter :: tmax=3.11e+02 -!!$ -!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 -!!$ real, parameter :: capa =3950.0 !heat capacity of sea water -!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 -!!$ real, parameter :: tmin=2.68e+02 !normal minimal temp -!!$ real, parameter :: tmax=3.11e+02 !normal max temp -!!$ real, parameter :: smin=1.0 !normal minimal salt -!!$ real, parameter :: smax=50. !normal maximum salt -!!$ real, parameter :: visct=1.e-5 !viscocity for temperature diffusion -!!$ real, parameter :: viscs=1.e-5 !viscocity for salt diffusion -!!$ -!!$ -end module module_nst_parameters diff --git a/physics/module_nst_water_prop.f90 b/physics/module_nst_water_prop.f90 deleted file mode 100644 index 6a183da52..000000000 --- a/physics/module_nst_water_prop.f90 +++ /dev/null @@ -1,762 +0,0 @@ -!>\file module_nst_water_prop.f90 -!! This file contains GFS NSST water property subroutines. - -!>\defgroup waterprop GFS NSST Water Property -!!This module contains GFS NSST water property subroutines. -!!\ingroup gfs_nst_main_mod -module module_nst_water_prop - use machine, only : kind_phys - use module_nst_parameters, only : t0k - ! - private - public :: rhocoef,density,sw_rad,sw_rad_aw,sw_rad_sum,sw_rad_upper,sw_rad_upper_aw,sw_rad_skin,grv,solar_time_from_julian,compjd, & - sw_ps_9b,sw_ps_9b_aw,get_dtzm_point,get_dtzm_2d - - ! - interface sw_ps_9b - module procedure sw_ps_9b - end interface - interface sw_ps_9b_aw - module procedure sw_ps_9b_aw - end interface - ! - interface sw_rad - module procedure sw_fairall_6exp_v1 ! sw_wick_v1 - end interface - interface sw_rad_aw - module procedure sw_fairall_6exp_v1_aw - end interface - interface sw_rad_sum - module procedure sw_fairall_6exp_v1_sum - end interface - interface sw_rad_upper - module procedure sw_soloviev_3exp_v2 - end interface - interface sw_rad_upper_aw - module procedure sw_soloviev_3exp_v2_aw - end interface - interface sw_rad_skin - module procedure sw_ohlmann_v1 - end interface -contains - ! ------------------------------------------------------ -!>\ingroup gfs_nst_main_mod -!! This subroutine computes thermal expansion coefficient (alpha) -!! and saline contraction coefficient (beta). - subroutine rhocoef(t, s, rhoref, alpha, beta) - ! ------------------------------------------------------ - - ! compute thermal expansion coefficient (alpha) - ! and saline contraction coefficient (beta) using - ! the international equation of state of sea water - ! (1980). ref: pond and pickard, introduction to - ! dynamical oceanography, pp310. - ! note: compression effects are not included - - implicit none - real(kind=kind_phys), intent(in) :: t, s, rhoref - real(kind=kind_phys), intent(out) :: alpha, beta - real(kind=kind_phys) :: tc - - tc = t - t0k - - alpha = & - 6.793952e-2 & - - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & - - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & - - 4.0899e-3 * s & - + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & - + 4.0 * 5.3875e-9 * tc**3 * s & - + 1.0227e-4 * s**1.5 - 2.0 * 1.6546e-6 * tc * s**1.5 - - ! note: rhoref - specify - ! - alpha = -alpha/rhoref - - beta = & - 8.24493e-1 - 4.0899e-3 * tc & - + 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 & - + 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 & - + 1.5 * 1.0227e-4 * tc * s**.5 & - - 1.5 * 1.6546e-6 * tc**2 * s**.5 & - + 2.0 * 4.8314e-4 * s - - beta = beta / rhoref - - end subroutine rhocoef - ! ---------------------------------------- -!>\ingroup gfs_nst_main_mod -!! This subroutine computes sea water density. - subroutine density(t, s, rho) - ! ---------------------------------------- - implicit none - - ! input - real(kind=kind_phys), intent(in) :: t !unit, k - real(kind=kind_phys), intent(in) :: s !unit, 1/1000 - ! output - real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 - ! local - real(kind=kind_phys) :: tc - - ! compute density using the international equation - ! of state of sea water 1980, (pond and pickard, - ! introduction to dynamical oceanography, pp310). - ! compression effects are not included - - rho = 0.0 - tc = t - t0k - - ! effect of temperature on density (lines 1-3) - ! effect of temperature and salinity on density (lines 4-8) - rho = & - 999.842594 + 6.793952e-2 * tc & - - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & - - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & - + 8.24493e-1 * s - 4.0899e-3 * tc * s & - + 7.6438e-5 * tc**2 * s - 8.2467e-7 * tc**3 * s & - + 5.3875e-9 * tc**4 * s - 5.72466e-3 * s**1.5 & - + 1.0227e-4 * tc * s**1.5 - 1.6546e-6 * tc**2 * s**1.5 & - + 4.8314e-4 * s**2 - - end subroutine density - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine computes the fraction of the solar radiation absorbed -!! by the depth z following Paulson and Simpson (1981) \cite paulson_and_simpson_1981 . - elemental subroutine sw_ps_9b(z,fxp) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real,intent(in):: z - real,intent(out):: fxp - real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - ! - if(z>0) then - fxp=1.0-(f(1)*exp(-z/gamma(1))+f(2)*exp(-z/gamma(2))+f(3)*exp(-z/gamma(3))+ & - f(4)*exp(-z/gamma(4))+f(5)*exp(-z/gamma(5))+f(6)*exp(-z/gamma(6))+ & - f(7)*exp(-z/gamma(7))+f(8)*exp(-z/gamma(8))+f(9)*exp(-z/gamma(9))) - else - fxp=0. - endif - ! - end subroutine sw_ps_9b - ! - !====================== - ! - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine - elemental subroutine sw_ps_9b_aw(z,aw) - ! - ! d(fw)/d(z) for 9-band - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real,intent(in):: z - real,intent(out):: aw - real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - ! - if(z>0) then - aw=(f(1)/gamma(1))*exp(-z/gamma(1))+(f(2)/gamma(2))*exp(-z/gamma(2))+(f(3)/gamma(3))*exp(-z/gamma(3))+ & - (f(1)/gamma(4))*exp(-z/gamma(4))+(f(2)/gamma(5))*exp(-z/gamma(5))+(f(6)/gamma(6))*exp(-z/gamma(6))+ & - (f(1)/gamma(7))*exp(-z/gamma(7))+(f(2)/gamma(8))*exp(-z/gamma(8))+(f(9)/gamma(9))*exp(-z/gamma(9)) - else - aw=0. - endif - ! - end subroutine sw_ps_9b_aw - ! - !====================== -!>\ingroup gfs_nst_main_mod -!! This subroutine computes fraction of the solar radiation absorbed by the ocean at the depth -!! z (Fairall et al. (1996) \cite fairall_et_al_1996, p. 1298) following Paulson and Simpson -!! (1981) \cite paulson_and_simpson_1981 . - elemental subroutine sw_fairall_6exp_v1(z,fxp) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: fxp - real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - real(kind=kind_phys),dimension(9) :: zgamma - real(kind=kind_phys),dimension(9) :: f_c - ! - if(z>0) then - zgamma=z/gamma - f_c=f*(1.-1./zgamma*(1-exp(-zgamma))) - fxp=sum(f_c) - else - fxp=0. - endif - ! - end subroutine sw_fairall_6exp_v1 - ! - !====================== - ! - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine calculates fraction of the solar radiation absorbed by the -!! ocean at the depth z (fairall et al.(1996) \cite fairall_et_al_1996; p.1298) -!! following Paulson and Simpson (1981) \cite paulson_and_simpson_1981. - elemental subroutine sw_fairall_6exp_v1_aw(z,aw) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! aw: d(fxp)/d(z) - ! - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: aw - real(kind=kind_phys) :: fxp - real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & - ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - real(kind=kind_phys),dimension(9) :: zgamma - real(kind=kind_phys),dimension(9) :: f_aw - ! - if(z>0) then - zgamma=z/gamma - f_aw=(f/z)*((gamma/z)*(1-exp(-zgamma))-exp(-zgamma)) - aw=sum(f_aw) - -! write(*,'(a,f6.2,f12.6,9f10.4)') 'z,aw in sw_rad_aw : ',z,aw,f_aw - - else - aw=0. - endif - ! - end subroutine sw_fairall_6exp_v1_aw - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine computes fraction of the solar radiation absorbed by the ocean at the -!! depth z (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1298) following Paulson and -!! Simpson (1981) \cite paulson_and_simpson_1981 . -!>\param[in] z depth (m) -!>\param[out] sum for convection depth calculation - elemental subroutine sw_fairall_6exp_v1_sum(z,sum) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! following paulson and simpson, 1981 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! sum: for convection depth calculation - ! - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: sum - real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) - real(kind=kind_phys),dimension(9) :: zgamma - real(kind=kind_phys),dimension(9) :: f_sum - ! -! zgamma=z/gamma -! f_sum=(zgamma/z)*exp(-zgamma) -! sum=sum(f_sum) - - sum=(1.0/gamma(1))*exp(-z/gamma(1))+(1.0/gamma(2))*exp(-z/gamma(2))+(1.0/gamma(3))*exp(-z/gamma(3))+ & - (1.0/gamma(4))*exp(-z/gamma(4))+(1.0/gamma(5))*exp(-z/gamma(5))+(1.0/gamma(6))*exp(-z/gamma(6))+ & - (1.0/gamma(7))*exp(-z/gamma(7))+(1.0/gamma(8))*exp(-z/gamma(8))+(1.0/gamma(9))*exp(-z/gamma(9)) - ! - end subroutine sw_fairall_6exp_v1_sum - ! - !====================== -!>\ingroup gfs_nst_main_mod -!! Solar radiation absorbed by the ocean at the depth z (Fairall et al. (1996) -!! \cite fairall_et_al_1996, p.1298) -!!\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) -!!\param[in] z depth (m) -!!\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) - elemental subroutine sw_fairall_simple_v1(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - ! - if(z>0) then - df_sol_z=f_sol_0*(0.137+11.0*z-6.6e-6/z*(1.-exp(-z/8.e-4))) - else - df_sol_z=0. - endif - ! - end subroutine sw_fairall_simple_v1 - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! solar radiation absorbed by the ocean at the depth z (Zeng and Beljaars (2005) -!! \cite zeng_and_beljaars_2005 , p.5). -!>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) -!>\param[in] z depth (m) -!>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) - elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5) - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - ! - if(z>0) then - df_sol_z=f_sol_0*(0.065+11.0*z-6.6e-5/z*(1.-exp(-z/8.e-4))) - else - df_sol_z=0. - endif - ! - end subroutine sw_wick_v1 - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod -!! This subroutine computes solar radiation absorbed by the ocean at the depth z -!! (Fairall et al.(1996) \cite fairall_et_al_1996 , p.1301) following -!! Soloviev and Vershinsky (1982) \cite soloviev_and_vershinsky_1982. -!>\param[in] f_sol_0 solar radiation at the ocean surface (\f$W m^{-2}\f$) -!>\param[in] z depth (m) -!>\param[out] df_sol_z solar radiation absorbed by the ocean at depth z (\f$W m^{-2}\f$) - elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) - ! following soloviev, 1982 - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - real(kind=kind_phys),dimension(3) :: f_c - real(kind=kind_phys), dimension(3), parameter :: f=(/0.45,0.27,0.28/) & - ,gamma=(/12.8,0.357,0.014/) - ! - if(z>0) then - f_c = f*gamma(int(1-exp(-z/gamma))) - df_sol_z = f_sol_0*(1.0-sum(f_c)/z) - else - df_sol_z = 0. - endif - ! - end subroutine sw_soloviev_3exp_v1 - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod - elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) - ! - ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) - ! following soloviev, 1982 - ! - ! input: - ! f_sol_0: solar radiation at the ocean surface (w/m^2) - ! z: depth (m) - ! - ! output: - ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z,f_sol_0 - real(kind=kind_phys),intent(out):: df_sol_z - ! - if(z>0) then - df_sol_z=f_sol_0*(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - +0.27*0.357*(1.-exp(-z/0.357)) & - +.45*12.82*(1.-exp(-z/12.82)))/z & - ) - else - df_sol_z=0. - endif - ! - end subroutine sw_soloviev_3exp_v2 - -!>\ingroup gfs_nst_main_mod - elemental subroutine sw_soloviev_3exp_v2_aw(z,aw) - ! - ! aw = d(fxp)/d(z) - ! following soloviev, 1982 - ! - ! input: - ! z: depth (m) - ! - ! output: - ! aw: d(fxp)/d(z) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: aw - real(kind=kind_phys):: fxp - ! - if(z>0) then - fxp=(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - + 0.27*0.357*(1.-exp(-z/0.357)) & - + 0.45*12.82*(1.-exp(-z/12.82)))/z & - ) - aw=1.0-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82)) - else - aw=0. - endif - end subroutine sw_soloviev_3exp_v2_aw - ! - ! - !====================== - ! -!>\ingroup gfs_nst_main_mod - elemental subroutine sw_ohlmann_v1(z,fxp) - ! - ! fraction of the solar radiation absorbed by the ocean at the depth z - ! - ! input: - ! z: depth (m) - ! - ! output: - ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) - ! - implicit none - real(kind=kind_phys),intent(in):: z - real(kind=kind_phys),intent(out):: fxp - ! - if(z>0) then - fxp=.065+11.*z-6.6e-5/z*(1.-exp(-z/8.0e-4)) - else - fxp=0. - endif - ! - end subroutine sw_ohlmann_v1 - ! - -!>\ingroup gfs_nst_main_mod -function grv(lat) - real(kind=kind_phys) :: lat - real(kind=kind_phys) :: gamma,c1,c2,c3,c4,pi,phi,x - gamma=9.7803267715 - c1=0.0052790414 - c2=0.0000232718 - c3=0.0000001262 - c4=0.0000000007 - pi=3.141593 - - phi=lat*pi/180 - x=sin(phi) - grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) - !print *,'grav=',grv,lat -end function grv - -!>\ingroup gfs_nst_main_mod -!>This subroutine computes solar time from the julian date. -subroutine solar_time_from_julian(jday,xlon,soltim) - ! - ! calculate solar time from the julian date - ! - implicit none - real(kind=kind_phys), intent(in) :: jday - real(kind=kind_phys), intent(in) :: xlon - real(kind=kind_phys), intent(out) :: soltim - real(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime - integer :: nn - ! - fjd=jday-floor(jday) - fjd=jday - xhr=floor(fjd*24.0)-sign(12.0,fjd-0.5) - xmin=nint(fjd*1440.0)-(xhr+sign(12.0,fjd-0.5))*60 - xsec=0 - intime=xhr+xmin/60.0+xsec/3600.0+24.0 - soltim=mod(xlon/15.0+intime,24.0)*3600.0 -end subroutine solar_time_from_julian - -! -!*********************************************************************** -! -!>\ingroup gfs_nst_main_mod -!> This subroutine computes julian day and fraction from year, -!! month, day and time UTC. - subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) -!fpp$ noconcur r -!$$$ subprogram documentation block -! . . . . -! subprogram: compjd computes julian day and fraction -! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07 -! -! abstract: computes julian day and fraction -! from year, month, day and time utc. -! -! program history log: -! 77-05-06 ray orzol,gfdl -! 98-05-15 iredell y2k compliance -! -! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) -! input argument list: -! jyr - year (4 digits) -! jmnth - month -! jday - day -! jhr - hour -! jmn - minutes -! output argument list: -! jd - julian day. -! fjd - fraction of the julian day. -! -! subprograms called: -! iw3jdn compute julian day number -! -! attributes: -! language: fortran. -! -!$$$ - use machine , only :kind_phys - implicit none -! - integer jyr,jmnth,jday,jhr,jmn,jd - integer iw3jdn - real (kind=kind_phys) fjd - jd=iw3jdn(jyr,jmnth,jday) - if(jhr.lt.12) then - jd=jd-1 - fjd=0.5+jhr/24.+jmn/1440. - else - fjd=(jhr-12)/24.+jmn/1440. - endif - end subroutine compjd - -!>\ingroup gfs_nst_main_mod -!>This subroutine computes dtm (the mean of \f$dT(z)\f$). - subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) -! ===================================================================== ! -! ! -! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! -! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! -! ! -! usage: ! -! ! -! call get_dtm12 ! -! ! -! inputs: ! -! (xt,xz,dt_cool,zc,z1,z2, ! -! outputs: ! -! dtm) ! -! ! -! program history log: ! -! ! -! 2015 -- xu li createad original code ! -! inputs: ! -! xt - real, heat content in dtl 1 ! -! xz - real, dtl thickness 1 ! -! dt_cool - real, sub-layer cooling amount 1 ! -! zc - sub-layer cooling thickness 1 ! -! z1 - lower bound of depth of sea temperature 1 ! -! z2 - upper bound of depth of sea temperature 1 ! -! outputs: ! -! dtm - mean of dT(z) (z1 to z2) 1 ! -! - use machine , only : kind_phys - - implicit none - - real (kind=kind_phys), intent(in) :: xt,xz,dt_cool,zc,z1,z2 - real (kind=kind_phys), intent(out) :: dtm -! Local variables - real (kind=kind_phys) :: dt_warm,dtw,dtc - -! -! get the mean warming in the range of z=z1 to z=z2 -! - dtw = 0.0 - if ( xt > 0.0 ) then - dt_warm = (xt+xt)/xz ! Tw(0) - if ( z1 < z2) then - if ( z2 < xz ) then - dtw = dt_warm*(1.0-(z1+z2)/(xz+xz)) - elseif ( z1 < xz .and. z2 >= xz ) then - dtw = 0.5*(1.0-z1/xz)*dt_warm*(xz-z1)/(z2-z1) - endif - elseif ( z1 == z2 ) then - if ( z1 < xz ) then - dtw = dt_warm*(1.0-z1/xz) - endif - endif - endif -! -! get the mean cooling in the range of z=z1 to z=z2 -! - dtc = 0.0 - if ( zc > 0.0 ) then - if ( z1 < z2) then - if ( z2 < zc ) then - dtc = dt_cool*(1.0-(z1+z2)/(zc+zc)) - elseif ( z1 < zc .and. z2 >= zc ) then - dtc = 0.5*(1.0-z1/zc)*dt_cool*(zc-z1)/(z2-z1) - endif - elseif ( z1 == z2 ) then - if ( z1 < zc ) then - dtc = dt_cool*(1.0-z1/zc) - endif - endif - endif - -! -! get the mean T departure from Tf in the range of z=z1 to z=z2 -! - dtm = dtw - dtc - - end subroutine get_dtzm_point - -!>\ingroup gfs_nst_main_mod - subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm) -!subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) -! ===================================================================== ! -! ! -! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! -! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! -! ! -! usage: ! -! ! -! call get_dtzm_2d ! -! ! -! inputs: ! -! (xt,xz,dt_cool,zc,z1,z2, ! -! outputs: ! -! dtm) ! -! ! -! program history log: ! -! ! -! 2015 -- xu li createad original code ! -! inputs: ! -! xt - real, heat content in dtl 1 ! -! xz - real, dtl thickness 1 ! -! dt_cool - real, sub-layer cooling amount 1 ! -! zc - sub-layer cooling thickness 1 ! -! wet - logical, flag for wet point (ocean or lake) 1 ! -! icy - logical, flag for ice point (ocean or lake) 1 ! -! nx - integer, dimension in x-direction (zonal) 1 ! -! ny - integer, dimension in y-direction (meridional) 1 ! -! z1 - lower bound of depth of sea temperature 1 ! -! z2 - upper bound of depth of sea temperature 1 ! -! nth - integer, num of openmp thread 1 ! -! outputs: ! -! dtm - mean of dT(z) (z1 to z2) 1 ! -! - use machine , only : kind_phys - - implicit none - - integer, intent(in) :: nx,ny, nth - real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc - logical, dimension(nx,ny), intent(in) :: wet -! logical, dimension(nx,ny), intent(in) :: wet,icy - real (kind=kind_phys), intent(in) :: z1,z2 - real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm -! Local variables - integer :: i,j - real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi - real (kind=kind_phys), parameter :: zero=0.0, half=0.5, one=1.0 - - -!$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi) - do j = 1, ny - do i= 1, nx - - dtm(i,j) = zero ! initialize dtm - - if ( wet(i,j) ) then -! -! get the mean warming in the range of z=z1 to z=z2 -! - dtw = zero - if ( xt(i,j) > zero ) then - xzi = one / xz(i,j) - dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0) - if (z1 < z2) then - if ( z2 < xz(i,j) ) then - dtw = dt_warm * (one-half*(z1+z2)*xzi) - elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then - dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1) - endif - elseif (z1 == z2 ) then - if (z1 < xz(i,j) ) then - dtw = dt_warm * (one-z1*xzi) - endif - endif - endif -! -! get the mean cooling in the range of z=0 to z=zsea -! - dtc = zero - if ( zc(i,j) > zero ) then - if ( z1 < z2) then - if ( z2 < zc(i,j) ) then - dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j))) - elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then - dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) - endif - elseif ( z1 == z2 ) then - if ( z1 < zc(i,j) ) then - dtc = dt_cool(i,j) * (one-z1/zc(i,j)) - endif - endif - endif -! get the mean T departure from Tf in the range of z=z1 to z=z2 - dtm(i,j) = dtw - dtc - endif ! if ( wet(i,j)) then - enddo - enddo -! - - end subroutine get_dtzm_2d - -end module module_nst_water_prop diff --git a/physics/h2o_def.f b/physics/photochem/h2o_def.f similarity index 100% rename from physics/h2o_def.f rename to physics/photochem/h2o_def.f diff --git a/physics/h2o_def.meta b/physics/photochem/h2o_def.meta similarity index 95% rename from physics/h2o_def.meta rename to physics/photochem/h2o_def.meta index 17f0f8779..92e1d61bd 100644 --- a/physics/h2o_def.meta +++ b/physics/photochem/h2o_def.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = h2o_def type = module - dependencies = machine.F + dependencies = ../hooks/machine.F [ccpp-arg-table] name = h2o_def diff --git a/physics/h2ointerp.f90 b/physics/photochem/h2ointerp.f90 similarity index 100% rename from physics/h2ointerp.f90 rename to physics/photochem/h2ointerp.f90 diff --git a/physics/h2ophys.f b/physics/photochem/h2ophys.f similarity index 100% rename from physics/h2ophys.f rename to physics/photochem/h2ophys.f diff --git a/physics/h2ophys.meta b/physics/photochem/h2ophys.meta similarity index 98% rename from physics/h2ophys.meta rename to physics/photochem/h2ophys.meta index afe50bda1..9e9b03647 100644 --- a/physics/h2ophys.meta +++ b/physics/photochem/h2ophys.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = h2ophys type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/module_ozphys.F90 b/physics/photochem/module_ozphys.F90 similarity index 100% rename from physics/module_ozphys.F90 rename to physics/photochem/module_ozphys.F90 diff --git a/physics/module_ozphys.meta b/physics/photochem/module_ozphys.meta similarity index 100% rename from physics/module_ozphys.meta rename to physics/photochem/module_ozphys.meta diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 deleted file mode 100644 index 2b63d98c5..000000000 --- a/physics/rrtmg_lw_pre.F90 +++ /dev/null @@ -1,26 +0,0 @@ -!>\file rrtmg_lw_pre.F90 -!! - module rrtmg_lw_pre - contains - -!>\defgroup rrtmg_lw_pre GFS RRTMG-LW scheme pre -!! This module contains RRTMG-LW pre module. -!> @{ -!> \section arg_table_rrtmg_lw_pre_run Argument Table -!! \htmlinclude rrtmg_lw_pre_run.html -!! - subroutine rrtmg_lw_pre_run (errmsg, errflg) - - implicit none - - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - end subroutine rrtmg_lw_pre_run - -!> @} - end module rrtmg_lw_pre diff --git a/physics/rrtmg_lw_pre.meta b/physics/rrtmg_lw_pre.meta deleted file mode 100644 index 9f6ec07c8..000000000 --- a/physics/rrtmg_lw_pre.meta +++ /dev/null @@ -1,24 +0,0 @@ -[ccpp-table-properties] - name = rrtmg_lw_pre - type = scheme - dependencies = - -######################################################################## -[ccpp-arg-table] - name = rrtmg_lw_pre_run - type = scheme -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp deleted file mode 160000 index 0dc54f5ec..000000000 --- a/physics/rte-rrtmgp +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 0dc54f5ecaeb1e1e342efd1e02d0bcd41737bde2 diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f deleted file mode 100644 index 2ca70666d..000000000 --- a/physics/sfc_nst.f +++ /dev/null @@ -1,696 +0,0 @@ -!>\file sfc_nst.f -!! This file contains the GFS NSST model. - -!> This module contains the CCPP-compliant GFS near-surface sea temperature scheme. - module sfc_nst - - contains - -!>\defgroup gfs_nst_main_mod GFS Near-Surface Sea Temperature Module -!! This module contains the CCPP-compliant GFS near-surface sea temperature scheme. -!> @{ -!! This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile. -!! \section arg_table_sfc_nst_run Argument Table -!! \htmlinclude sfc_nst_run.html -!! -!> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm - subroutine sfc_nst_run & - & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: - & pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & - & lseaspray, fm, fm10, & - & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & - & sinlat, stress, & - & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & - & wind, flag_iter, flag_guess, nstf_name1, nstf_name4, & - & nstf_name5, lprnt, ipr, thsfc_loc, & - & tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & ! --- input/output: - & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, & - & qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & ! --- outputs: - & ) -! -! ===================================================================== ! -! description: ! -! ! -! ! -! usage: ! -! ! -! call sfc_nst ! -! inputs: ! -! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! -! lseaspray, fm, fm10, ! -! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! -! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! -! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! -! nstf_name5, lprnt, ipr, thsfc_loc, ! -! input/outputs: ! -! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, ! -! z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, ! -! -- outputs: -! qsurf, gflux, cmm, chh, evap, hflx, ep ! -! ) -! ! -! ! -! subprogram/functions called: w3movdat, iw3jdn, fpvs, density, ! -! rhocoef, cool_skin, warm_layer, jacobi_temp. ! -! ! -! program history log: ! -! 2007 -- xu li createad original code ! -! 2008 -- s. moorthi adapted to the parallel version ! -! may 2009 -- y.-t. hou modified to include input lw surface ! -! emissivity from radiation. also replaced the ! -! often comfusing combined sw and lw suface ! -! flux with separate sfc net sw flux (defined ! -! as dn-up) and lw flux. added a program doc block. ! -! sep 2009 -- s. moorthi removed rcl and additional reformatting ! -! and optimization + made pa as input pressure unit.! -! 2009 -- xu li recreatead the code ! -! feb 2010 -- s. moorthi added some changes made to the previous ! -! version ! -! Jul 2016 -- X. Li, modify the diurnal warming event reset ! -! ! -! ! -! ==================== definition of variables ==================== ! -! ! -! inputs: size ! -! im - integer, horiz dimension 1 ! -! ps - real, surface pressure (pa) im ! -! u1, v1 - real, u/v component of surface layer wind (m/s) im ! -! t1 - real, surface layer mean temperature ( k ) im ! -! q1 - real, surface layer mean specific humidity im ! -! tref - real, reference/foundation temperature ( k ) im ! -! cm - real, surface exchange coeff for momentum (m/s) im ! -! ch - real, surface exchange coeff heat & moisture(m/s) im ! -! lseaspray- logical, .t. for parameterization for sea spray 1 ! -! fm - real, a stability profile function for momentum im ! -! fm10 - real, a stability profile function for momentum im ! -! at 10m ! -! prsl1 - real, surface layer mean pressure (pa) im ! -! prslki - real, im ! -! prsik1 - real, im ! -! prslk1 - real, im ! -! wet - logical, =T if any ocn/lake water (F otherwise) im ! -! use_lake_model- logical, =T if flake model is used for lake im ! -! icy - logical, =T if any ice im ! -! xlon - real, longitude (radians) im ! -! sinlat - real, sin of latitude im ! -! stress - real, wind stress (n/m**2) im ! -! sfcemis - real, sfc lw emissivity (fraction) im ! -! dlwflx - real, total sky sfc downward lw flux (w/m**2) im ! -! sfcnsw - real, total sky sfc netsw flx into ocean (w/m**2) im ! -! rain - real, rainfall rate (kg/m**2/s) im ! -! timestep - real, timestep interval (second) 1 ! -! kdt - integer, time step counter 1 ! -! solhr - real, fcst hour at the end of prev time step 1 ! -! xcosz - real, consine of solar zenith angle 1 ! -! wind - real, wind speed (m/s) im ! -! flag_iter- logical, execution or not im ! -! when iter = 1, flag_iter = .true. for all grids im ! -! when iter = 2, flag_iter = .true. when wind < 2 im ! -! for both land and ocean (when nstf_name1 > 0) im ! -! flag_guess-logical, .true.= guess step to get CD et al im ! -! when iter = 1, flag_guess = .true. when wind < 2 im ! -! when iter = 2, flag_guess = .false. for all grids im ! -! nstf_name - integers , NSST related flag parameters 1 ! -! nstf_name1 : 0 = NSSTM off 1 ! -! 1 = NSSTM on but uncoupled 1 ! -! 2 = NSSTM on and coupled 1 ! -! nstf_name4 : zsea1 in mm 1 ! -! nstf_name5 : zsea2 in mm 1 ! -! lprnt - logical, control flag for check print out 1 ! -! ipr - integer, grid index for check print out 1 ! -! thsfc_loc- logical, flag for reference pressure in theta 1 ! -! ! -! input/outputs: -! li added for oceanic components -! tskin - real, ocean surface skin temperature ( k ) im ! -! tsurf - real, the same as tskin ( k ) but for guess run im ! -! xt - real, heat content in dtl im ! -! xs - real, salinity content in dtl im ! -! xu - real, u-current content in dtl im ! -! xv - real, v-current content in dtl im ! -! xz - real, dtl thickness im ! -! zm - real, mxl thickness im ! -! xtts - real, d(xt)/d(ts) im ! -! xzts - real, d(xz)/d(ts) im ! -! dt_cool - real, sub-layer cooling amount im ! -! d_conv - real, thickness of free convection layer (fcl) im ! -! z_c - sub-layer cooling thickness im ! -! c_0 - coefficient1 to calculate d(tz)/d(ts) im ! -! c_d - coefficient2 to calculate d(tz)/d(ts) im ! -! w_0 - coefficient3 to calculate d(tz)/d(ts) im ! -! w_d - coefficient4 to calculate d(tz)/d(ts) im ! -! ifd - real, index to start dtlm run or not im ! -! qrain - real, sensible heat flux due to rainfall (watts) im ! - -! outputs: ! - -! qsurf - real, surface air saturation specific humidity im ! -! gflux - real, soil heat flux (w/m**2) im ! -! cmm - real, im ! -! chh - real, im ! -! evap - real, evaperation from latent heat flux im ! -! hflx - real, sensible heat flux im ! -! ep - real, potential evaporation im ! -! ! -! ===================================================================== ! - use machine , only : kind_phys - use funcphys, only : fpvs - use date_def, only : idate - use module_nst_water_prop, only: get_dtzm_point - use module_nst_parameters, only : t0k,cp_w,omg_m,omg_sh, & - & sigma_r,solar_time_6am,ri_c,z_w_max,delz,wd_max, & - & rad2deg,const_rot,tau_min,tw_max,sst_max - use module_nst_water_prop, only: solar_time_from_julian, & - & density,rhocoef,compjd,grv & - &, sw_ps_9b - use nst_module, only : cool_skin,dtm_1p,cal_w,cal_ttop, & - & convdepth,dtm_1p_fca,dtm_1p_tla, & - & dtm_1p_mwa,dtm_1p_mda,dtm_1p_mta, & - & dtl_reset -! - implicit none - - integer, parameter :: kp = kind_phys -! -! --- constant parameters: - real (kind=kind_phys), parameter :: f24 = 24.0_kp ! hours/day - real (kind=kind_phys), parameter :: f1440 = 1440.0_kp ! minutes/day - real (kind=kind_phys), parameter :: czmin = 0.0001_kp ! cos(89.994) - real (kind=kind_phys), parameter :: zero = 0.0_kp, one = 1.0_kp - - -! --- inputs: - integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4, & - & nstf_name5 - real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & - & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice - real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tref, cm, ch, fm, fm10, & - & prsl1, prslki, prsik1, prslk1, xlon, xcosz, & - & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind - real (kind=kind_phys), intent(in) :: timestep - real (kind=kind_phys), intent(in) :: solhr - -! For sea spray effect - logical, intent(in) :: lseaspray -! - logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet - integer, dimension(:), intent(in) :: use_lake_model -! &, icy - logical, intent(in) :: lprnt - logical, intent(in) :: thsfc_loc - -! --- input/outputs: -! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation - real (kind=kind_phys), dimension(:), intent(inout) :: tskin, & - & tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & - & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: & - & qsurf, gflux, cmm, chh, evap, hflx, ep - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! -! locals -! - integer :: k,i -! - real (kind=kind_phys), dimension(im) :: q0, qss, rch, - & rho_a, theta1, tv1, wndmag - - real(kind=kind_phys) elocp,tem,cpinv,hvapi -! -! nstm related prognostic fields -! - logical flag(im) - real (kind=kind_phys), dimension(im) :: - & xt_old, xs_old, xu_old, xv_old, xz_old,zm_old,xtts_old, - & xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old - - real(kind=kind_phys) ulwflx(im), nswsfc(im) -! real(kind=kind_phys) rig(im), -! & ulwflx(im),dlwflx(im), -! & slrad(im),nswsfc(im) - real(kind=kind_phys) alpha,beta,rho_w,f_nsol,sss,sep, - & cosa,sina,taux,tauy,grav,dz,t0,ttop0,ttop - - real(kind=kind_phys) le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich - real(kind=kind_phys) rnl_ts,hs_ts,hl_ts,rf_ts,q_ts - real(kind=kind_phys) fw,q_warm - real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz - real(kind=kind_phys) zsea1,zsea2,soltim - logical do_nst - -! external functions called: iw3jdn - integer :: iw3jdn -! -! parameters for sea spray effect -! - real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, - & bb1, hflxs, evaps, ptem -! -! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, -! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, -! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, - real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, - & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 -! -!====================================================================================================== -cc - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (nstf_name1 == 0) return ! No NSST model used - - cpinv = one/cp - hvapi = one/hvap - elocp = hvap/cp - - sss = 34.0_kp ! temporarily, when sea surface salinity data is not ready -! -! flag for open water and where the iteration is on -! - do_nst = .false. - do i = 1, im -! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) - flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1 - do_nst = do_nst .or. flag(i) - enddo - if (.not. do_nst) return -! -! save nst-related prognostic fields for guess run -! - do i=1, im -! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then - if(wet(i) .and. flag_guess(i) .and. use_lake_model(i)/=1) then - xt_old(i) = xt(i) - xs_old(i) = xs(i) - xu_old(i) = xu(i) - xv_old(i) = xv(i) - xz_old(i) = xz(i) - zm_old(i) = zm(i) - xtts_old(i) = xtts(i) - xzts_old(i) = xzts(i) - ifd_old(i) = ifd(i) - tskin_old(i) = tskin(i) - dt_cool_old(i) = dt_cool(i) - z_c_old(i) = z_c(i) - endif - enddo - - -! --- ... initialize variables. all units are m.k.s. unless specified. -! ps is in pascals, wind is wind speed, theta1 is surface air -! estimated from level 1 temperature, rho_a is air density and -! qss is saturation specific humidity at the water surface -!! - do i = 1, im - if ( flag(i) ) then - - nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) - wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) - - q0(i) = max(q1(i), 1.0e-8_kp) - - if(thsfc_loc) then ! Use local potential temperature - theta1(i) = t1(i) * prslki(i) - else ! Use potential temperature referenced to 1000 hPa - theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer - endif - - tv1(i) = t1(i) * (one + rvrdm1*q0(i)) - rho_a(i) = prsl1(i) / (rd*tv1(i)) - qss(i) = fpvs(tsurf(i)) ! pa - qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa -! - evap(i) = zero - hflx(i) = zero - gflux(i) = zero - ep(i) = zero - -! --- ... rcp = rho cp ch v - - rch(i) = rho_a(i) * cp * ch(i) * wind(i) - cmm(i) = cm (i) * wind(i) - chh(i) = rho_a(i) * ch(i) * wind(i) - -!> - Calculate latent and sensible heat flux over open water with tskin. -! at previous time step - evap(i) = elocp * rch(i) * (qss(i) - q0(i)) - qsurf(i) = qss(i) - - if(thsfc_loc) then ! Use local potential temperature - hflx(i) = rch(i) * (tsurf(i) - theta1(i)) - else ! Use potential temperature referenced to 1000 hPa - hflx(i) = rch(i) * (tsurf(i)/prsik1(i) - theta1(i)) - endif - -! if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=', -! & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i) -! &,' tsurf=',tsurf(i) - endif - enddo - -! run nst model: dtm + slm -! - zsea1 = 0.001_kp*real(nstf_name4) - zsea2 = 0.001_kp*real(nstf_name5) - -!> - Call module_nst_water_prop::density() to compute sea water density. -!> - Call module_nst_water_prop::rhocoef() to compute thermal expansion -!! coefficient (\a alpha) and saline contraction coefficient (\a beta). - do i = 1, im - if ( flag(i) ) then - tsea = tsurf(i) - t12 = tsea*tsea - ulwflx(i) = sfcemis(i) * sbc * t12 * t12 - alon = xlon(i)*rad2deg - grav = grv(sinlat(i)) - soltim = mod(alon/15.0_kp + solhr, 24.0_kp)*3600.0_kp - call density(tsea,sss,rho_w) ! sea water density - call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta -! -!> - Calculate sensible heat flux (\a qrain) due to rainfall. -! - le = (2.501_kp-0.00237_kp*tsea)*1e6_kp - dwat = 2.11e-5_kp*(t1(i)/t0k)**1.94_kp ! water vapor diffusivity - dtmp = (one+3.309e-3_kp*(t1(i)-t0k)-1.44e-6_kp*(t1(i)-t0k) - & * (t1(i)-t0k))*0.02411_kp/(rho_a(i)*cp) ! heat diffusivity - wetc = 622.0_kp*le*qss(i)/(rd*t1(i)*t1(i)) - alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor - tem = (1.0e3_kp * rain(i) / rho_w) * alfac * cp_w - qrain(i) = tem * (tsea-t1(i)+1.0e3_kp*(qss(i)-q0(i))*le/cp) - -!> - Calculate input non solar heat flux as upward = positive to models here - - f_nsol = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i) - & + omg_sh*qrain(i) - -! if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=', -! &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i) -! &,' omg_sh=',omg_sh,' qrain=',qrain(i) - - sep = sss*(evap(i)/le-rain(i))/rho_w - ustar_a = sqrt(stress(i)/rho_a(i)) ! air friction velocity -! -! sensitivities of heat flux components to ts -! - rnl_ts = 4.0_kp*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) - hs_ts = rch(i) - hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) - rf_ts = tem * (one+rch(i)*hl_ts) - q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts -! -!> - Call cool_skin(), which is the sub-layer cooling parameterization -!! (Fairfall et al. (1996) \cite fairall_et_al_1996). -! & calculate c_0, c_d -! - call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta - &, rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le - &, dt_cool(i),z_c(i),c_0(i),c_d(i)) - - tem = one / wndmag(i) - cosa = u1(i)*tem - sina = v1(i)*tem - taux = max(stress(i),tau_min)*cosa - tauy = max(stress(i),tau_min)*sina - fc = const_rot*sinlat(i) -! -! Run DTM-1p system. -! - if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then - else - ifd(i) = one -! -! calculate fcl thickness with current forcing and previous time's profile -! -! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i) - -!> - Call convdepth() to calculate depth for convective adjustments. - if ( f_nsol > zero .and. xt(i) > zero ) then - call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w - &, alpha,beta,xt(i),xs(i),xz(i),d_conv(i)) - else - d_conv(i) = zero - endif - -! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i) -! -! determine rich: wind speed dependent (right now) -! -! if ( wind(i) < 1.0 ) then -! rich = 0.25 + 0.03*wind(i) -! elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then -! rich = 0.25 + 0.1*wind(i) -! elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then -! rich = 0.25 + 0.6*wind(i) -! elseif ( wind(i) >= 6.0 ) then -! rich = 0.25 + min(0.8*wind(i),0.50) -! endif - - rich = ri_c - -!> - Call the diurnal thermocline layer model dtm_1p(). - call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i), - & f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon, - & sinlat(i),soltim,grav,le,d_conv(i), - & xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - -! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) - -! apply mda - if ( xt(i) > zero ) then -!> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply -!! minimum depth adjustment (mda). - call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i)) - if ( xz(i) >= z_w_max ) then -!> - If \a dtl thickness >= module_nst_parameters::z_w_max, call dtl_reset() -!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max. - call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i), - & xzts(i)) - -! if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max=' -! &,z_w_max - endif - -! apply fca - if ( d_conv(i) > zero ) then -!> - If thickness of free convection layer > 0.0, call dtm_1p_fca() -!! to apply free convection adjustment. -!> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset() -!! to reset xt/xs/x/xv to zero, and xz to module_nst_parameters::z_w_max(). - call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i)) - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif - -! if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i) - -! apply tla - dz = min(xz(i),max(d_conv(i),delz)) -! -!> - Call sw_ps_9b() to compute the fraction of the solar radiation -!! absorbed by the depth \a delz (Paulson and Simpson (1981) \cite paulson_and_simpson_1981). -!! And calculate the total heat absorbed in warm layer. - call sw_ps_9b(delz,fw) - q_warm = fw*nswsfc(i)-f_nsol !total heat absorbed in warm layer - -!> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with -!! thickness of \a dz. - if ( q_warm > zero ) then - call cal_ttop(kdt,timestep,q_warm,rho_w,dz, - & xt(i),xz(i),ttop0) - -! if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=', -! &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i), -! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i), -! &' xz=',xz(i),' qrain=',qrain(i) - - ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i)))) - -! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i) -! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz -! &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0 - -!> - Call dtm_1p_tla() to apply top layer adjustment. - if ( ttop > ttop0 ) then - call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i)) - -! if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=', -! &z_w_max - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif - endif ! if ( q_warm > 0.0 ) then - -! if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i) - -! apply mwa -!> - Call dt_1p_mwa() to apply maximum warming adjustment. - t0 = (xt(i)+xt(i))/xz(i) - if ( t0 > tw_max ) then - call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i)) - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif - -! if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i) - -! apply mta -!> - Call dtm_1p_mta() to apply maximum temperature adjustment. - sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i) - - if ( sstc > sst_max ) then - dta = sstc - sst_max - call dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i)) -! write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i), -! & sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i) - if ( xz(i) >= z_w_max ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - endif -! - endif ! if ( xt(i) > 0.0 ) then -! reset dtl at midnight and when solar zenith angle > 89.994 degree - if ( abs(soltim) < 2.0_kp*timestep ) then - call dtl_reset - & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) - endif - - endif ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day - -! if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i) - -! update tsurf (when flag(i) .eqv. .true. ) -!> - Call get_dtzm_point() to computes \a dtz and \a tsurf. - call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), - & zsea1,zsea2,dtz) - tsurf(i) = max(tgice, tref(i) + dtz ) - -! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=', -! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i) - -!> - Call cal_w() to calculate \a w_0 and \a w_d. - if ( xt(i) > zero ) then - call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i)) - else - w_0(i) = zero - w_d(i) = zero - endif - -! if ( xt(i) > 0.0 ) then -! rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i)) -! & /(2.0*(xu(i)*xu(i)+xv(i)*xv(i))) -! else -! rig(i) = 0.25 -! endif - -! qrain(i) = rig(i) - zm(i) = wind(i) - - endif - enddo - -! restore nst-related prognostic fields for guess run - do i=1, im -! if (wet(i) .and. .not.icy(i)) then - if (wet(i) .and. use_lake_model(i)/=1) then - if (flag_guess(i)) then ! when it is guess of - xt(i) = xt_old(i) - xs(i) = xs_old(i) - xu(i) = xu_old(i) - xv(i) = xv_old(i) - xz(i) = xz_old(i) - zm(i) = zm_old(i) - xtts(i) = xtts_old(i) - xzts(i) = xzts_old(i) - ifd(i) = ifd_old(i) - tskin(i) = tskin_old(i) - dt_cool(i) = dt_cool_old(i) - z_c(i) = z_c_old(i) - else -! -! update tskin when coupled and not guess run -! (all other NSST variables have been updated in this case) -! - if ( nstf_name1 > 1 ) then - tskin(i) = tsurf(i) - endif ! if nstf_name1 > 1 then - endif ! if flag_guess(i) then - endif ! if wet(i) .and. .not.icy(i) then - enddo - -! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i) - - if ( nstf_name1 > 1 ) then -!> - Calculate latent and sensible heat flux over open water with updated tskin -!! for the grids of open water and the iteration is on. - do i = 1, im - if ( flag(i) ) then - qss(i) = fpvs( tskin(i) ) - qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) - qsurf(i) = qss(i) - evap(i) = elocp*rch(i) * (qss(i) - q0(i)) - - if(thsfc_loc) then ! Use local potential temperature - hflx(i) = rch(i) * (tskin(i) - theta1(i)) - else ! Use potential temperature referenced to 1000 hPa - hflx(i) = rch(i) * (tskin(i)/prsik1(i) - theta1(i)) - endif - - endif - enddo - endif ! if ( nstf_name1 > 1 ) then -! -!> - Include sea spray effects -! - do i=1,im - if(lseaspray .and. flag(i)) then - f10m = fm10(i) / fm(i) - u10m = f10m * u1(i) - v10m = f10m * v1(i) - ws10 = sqrt(u10m*u10m + v10m*v10m) - ws10 = max(ws10,1.) - ws10 = min(ws10,ws10cr) - tem = .015 * ws10 * ws10 - ru10 = 1. - .087 * log(10./tem) - qss1 = fpvs(t1(i)) - qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) - tem = rd * cp * t1(i) * t1(i) - tem = 1. + eps * hvap * hvap * qss1 / tem - bb1 = 1. / tem - evaps = conlf * (ws10**5.4) * ru10 * bb1 - evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i)) - evap(i) = evap(i) + alps * evaps - hflxs = consf * (ws10**3.4) * ru10 - hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i)) - ptem = alps - gams - hflx(i) = hflx(i) + bets * hflxs - ptem * evaps - endif - enddo -! - do i=1,im - if ( flag(i) ) then - tem = one / rho_a(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - endif - enddo -! -! if (lprnt) print *,' tskin=',tskin(ipr) - - return - end subroutine sfc_nst_run -!> @} - end module sfc_nst diff --git a/physics/sfc_nst_post.f b/physics/sfc_nst_post.f deleted file mode 100644 index 83bc2f273..000000000 --- a/physics/sfc_nst_post.f +++ /dev/null @@ -1,93 +0,0 @@ -!> \file sfc_nst_post.f -!! This file contains code to be executed after the GFS NSST model. - - module sfc_nst_post - - contains - -! \defgroup GFS_NSST_POST GFS Near-Surface Sea Temperature Post - -!> \section arg_table_sfc_nst_post_run Argument Table -!! \htmlinclude sfc_nst_post_run.html -!! -! \section NSST_general_post_algorithm General Algorithm -! -! \section NSST_detailed_post_algorithm Detailed Algorithm -! @{ - subroutine sfc_nst_post_run & - & ( im, kdt, rlapse, tgice, wet, use_lake_model, icy, oro, & - & oro_uf, nstf_name1, & - & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & - & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & - & ) - - use machine , only : kind_phys - use module_nst_water_prop, only: get_dtzm_2d - - implicit none - - integer, parameter :: kp = kind_phys - -! --- inputs: - integer, intent(in) :: im, kdt, nthreads - logical, dimension(:), intent(in) :: wet, icy - integer, dimension(:), intent(in) :: use_lake_model - real (kind=kind_phys), intent(in) :: rlapse, tgice - real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf - integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 - real (kind=kind_phys), dimension(:), intent(in) :: xt, xz, & - & dt_cool, z_c, tref, xlon - -! --- input/outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: tsurf_wat, & - & tsfc_wat - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(out) :: dtzm - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i - real(kind=kind_phys) :: zsea1, zsea2 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), -! & ' kdt=',kdt - -! do i = 1, im -! if (wet(i) .and. .not. icy(i)) then -! tsurf_wat(i) = tsurf_wat(i) - (oro(i)-oro_uf(i)) * rlapse -! endif -! enddo - -! --- ... run nsst model ... --- - - if (nstf_name1 > 1) then - zsea1 = 0.001_kp*real(nstf_name4) - zsea2 = 0.001_kp*real(nstf_name5) - call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, & - & im, 1, nthreads, dtzm) - do i = 1, im -! if (wet(i) .and. .not.icy(i)) then -! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then - if (wet(i) .and. use_lake_model(i) /=1) then - tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) -! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & -! (oro(i)-oro_uf(i))*rlapse - endif - enddo - endif - -! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt - - return - end subroutine sfc_nst_post_run - - end module sfc_nst_post diff --git a/physics/sfc_nst_pre.f b/physics/sfc_nst_pre.f deleted file mode 100644 index 77ff61f00..000000000 --- a/physics/sfc_nst_pre.f +++ /dev/null @@ -1,96 +0,0 @@ -!> \file sfc_nst_pre.f -!! This file contains preparation for the GFS NSST model. - - module sfc_nst_pre - - contains - -!> \defgroup GFS_NSST_PRE GFS Near-Surface Sea Temperature Pre -!! -!! The NSST scheme is one of the three schemes used to represent the -!! surface in the GFS physics suite. The other two are the Noah land -!! surface model and the sice simplified ice model. -!! -!! \section arg_table_sfc_nst_pre_run Argument Table -!! \htmlinclude sfc_nst_pre_run.html -!! -!> \section NSST_general_pre_algorithm General Algorithm - subroutine sfc_nst_pre_run - & (im, wet, tgice, tsfco, tsurf_wat, - & tseal, xt, xz, dt_cool, z_c, tref, cplflx, - & oceanfrac, nthreads, errmsg, errflg) - - use machine , only : kind_phys - use module_nst_water_prop, only: get_dtzm_2d - - implicit none - - integer, parameter :: kp = kind_phys - -! --- inputs: - integer, intent(in) :: im, nthreads - logical, dimension(:), intent(in) :: wet - real (kind=kind_phys), intent(in) :: tgice - real (kind=kind_phys), dimension(:), intent(in) :: - & tsfco, xt, xz, dt_cool, z_c, oceanfrac - logical, intent(in) :: cplflx - -! --- input/outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: - & tsurf_wat, tseal, tref - -! --- outputs: - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - integer :: i - real(kind=kind_phys), parameter :: zero = 0.0_kp, - & one = 1.0_kp, - & half = 0.5_kp, - & omz1 = 2.0_kp - real(kind=kind_phys) :: tem1, tem2, dnsst - real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i=1,im - if (wet(i) .and. oceanfrac(i) > 0.0) then -! tem = (oro(i)-oro_uf(i)) * rlapse - ! DH* 20190927 simplyfing this code because tem is zero - !tem = zero - !tseal(i) = tsfco(i) + tem - tseal(i) = tsfco(i) - !tsurf_wat(i) = tsurf_wat(i) + tem - ! *DH - endif - enddo -! -! update tsfc & tref with T1 from OGCM & NSST Profile if coupled -! - if (cplflx) then - z_c_0 = zero - call get_dtzm_2d (xt, xz, dt_cool, & - & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) - do i=1,im - if (wet(i) .and. oceanfrac(i) > zero ) then -! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf - tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile -! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update -! tseal(i) = tsfc_wat(i) - if (abs(xz(i)) > zero) then - tem2 = one / xz(i) - else - tem2 = zero - endif - tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) - tsurf_wat(i) = tseal(i) - endif - enddo - endif - - return - end subroutine sfc_nst_pre_run - end module sfc_nst_pre diff --git a/physics/smoke_dust/coarsepm_settling_mod.F90 b/physics/smoke_dust/coarsepm_settling_mod.F90 index 9061840c3..b044edb67 100755 --- a/physics/smoke_dust/coarsepm_settling_mod.F90 +++ b/physics/smoke_dust/coarsepm_settling_mod.F90 @@ -8,7 +8,7 @@ module coarsepm_settling_mod CONTAINS -SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & +SUBROUTINE coarsepm_settling_driver(dt,t_phy, & chem,rho_phy,dz8w,p8w,p_phy,sedim, & area,g,num_chem, & ids,ide, jds,jde, kds,kde, & @@ -24,7 +24,7 @@ SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & its,ite, jts,jte, kts,kte REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),INTENT(INOUT ) :: chem REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy,rel_hum + INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy REAL(kind_phys), DIMENSION( ims:ime , jms:jme ),INTENT(IN ) :: area REAL(kind_phys), INTENT(IN ) :: dt,g @@ -64,7 +64,6 @@ SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g airden(1,1,kk)=rho_phy(i,k,j) tmp(1,1,kk)=t_phy(i,k,j) - rh(1,1,kk) = rel_hum(i,k,j) ! hli do nv = 1, num_chem chem_before(i,j,k,nv) = chem(i,k,j,nv) enddo @@ -82,7 +81,7 @@ SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & call settling(1, 1, lmx, 1,g,dyn_visc, & dust, tmp, p_mid, delz, airmas, & - den_dust, reff_dust, dt, bstl_dust, rh, idust, airden) + den_dust, reff_dust, dt, bstl_dust, idust, airden) kk = 0 do k = kts,kte @@ -111,7 +110,7 @@ END SUBROUTINE coarsepm_settling_driver subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & tc, tmp, p_mid, delz, airmas, & - den, reff, dt, bstl, rh, idust, airden) + den, reff, dt, bstl, idust, airden) ! **************************************************************************** ! * * ! * Calculate the loss by settling, using an implicit method * @@ -131,7 +130,7 @@ subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & INTEGER :: ntdt REAL(kind_phys), INTENT(IN) :: dt,g0,dyn_visc REAL(kind_phys), INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & - airmas(imx,jmx,lmx), rh(imx,jmx,lmx), & + airmas(imx,jmx,lmx), & den(nmx), reff(nmx),p_mid(imx,jmx,lmx),& airden(imx,jmx,lmx) REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) diff --git a/physics/smoke_dust/dep_data_mod.F90 b/physics/smoke_dust/dep_data_mod.F90 new file mode 100755 index 000000000..bf9ae7f0c --- /dev/null +++ b/physics/smoke_dust/dep_data_mod.F90 @@ -0,0 +1,193 @@ +!>\file dep_data_mod.F90 +!! This file contains data for the dry deposition modules. +module dep_data_mod + + use machine , only : kind_phys + + integer, parameter :: nvegtype = 25 + real(kind_phys), dimension(nvegtype), parameter :: & + kpart = (/500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500. /) + real(kind_phys), parameter :: max_dep_vel = 0.005 ! m/s (may need to set per species) + real(kind_phys), parameter :: dep_ref_hgt = 2.0 ! Meters + real(kind_phys), parameter :: pi = 3.1415926536 +! 3*PI + REAL(kind_phys), PARAMETER :: threepi=3.0*pi + real(kind_phys), parameter :: gravity = 9.81 +! mean gravitational acceleration [ m/sec**2 ] + REAL(kind_phys), PARAMETER :: grav=9.80622 + real(kind_phys), parameter :: boltzmann = 1.3807e-16 +! universal gas constant [ J/mol-K ] + REAL(kind_phys), PARAMETER :: rgasuniv=8.314510 +! Avogadro's Constant [ 1/mol ] + REAL, PARAMETER :: avo=6.0221367E23 + ! Boltzmann's Constant [ J / K ]i\ + REAL(kind_phys), PARAMETER :: boltz=rgasuniv/avo + real(kind_phys), parameter :: Cb = 2., Cim = 0.4, alpha = 0.8, Cin = 2.5, vv = 0.8 + real(kind_phys), parameter :: A_for = 0.1 ! forest + real(kind_phys), parameter :: A_grs = 0.2 ! grass + real(kind_phys), parameter :: A_wat = 100. ! water + real(kind_phys), parameter :: eps0_for = 0.8*0.01 ! forest + real(kind_phys), parameter :: eps0_grs = 0.4*0.01 ! grass + real(kind_phys), parameter :: eps0_wat = 0.6*0.01 ! water + + REAL(kind_phys), PARAMETER :: one3=1.0/3.0 + REAL(kind_phys), PARAMETER :: two3=2.0/3.0 +! SQRT( 2 ) + REAL(kind_phys), PARAMETER :: sqrt2=1.4142135623731 +! SQRT( PI ) + REAL(kind_phys), PARAMETER :: sqrtpi=1.7724539 + REAL(kind_phys) :: karman = 0.4 ! von Karman constant + REAL(kind_phys), PARAMETER :: conmin= 1.E-16 + REAL(kind_phys), PARAMETER :: pirs=3.14159265358979324 + REAL(kind_phys), PARAMETER :: f6dpi=6.0/pirs + REAL(kind_phys), PARAMETER :: f6dpim9=1.0E-9*f6dpi + REAL(kind_phys), PARAMETER :: rhosmoke = 1.4E3 + REAL(kind_phys), PARAMETER :: rhodust = 2.6E3 + REAL(kind_phys), PARAMETER :: smokefac=f6dpim9/rhosmoke + REAL(kind_phys), PARAMETER :: dustfac=f6dpim9/rhodust +! starting standard surface temperature [ K ] + REAL(kind_phys), PARAMETER :: tss0=288.15 + REAL(kind_phys), PARAMETER :: sigma1 = 1.8 + REAL(kind_phys), PARAMETER :: mean_diameter1 = 4.e-8 + REAL(kind_phys), PARAMETER :: fact_wfa = 1.e-9*6.0/pirs*exp(4.5*log(sigma1)**2)/mean_diameter1**3 + REAL(kind_phys), PARAMETER :: sginia=2.00 +! initial sigma-G for nucleimode + REAL(kind_phys), PARAMETER :: sginin=1.70 +! initial sigma-G for coarse mode + REAL(kind_phys), PARAMETER :: sginic=2.5 +! starting standard surface pressure [ Pa ] + REAL(kind_phys), PARAMETER :: pss0=101325.0 +! lowest particle diameter ( m ) + REAL(kind_phys), PARAMETER :: dgmin=1.0E-09 +! lowest particle density ( Kg/m**3 ) + REAL(kind_phys), PARAMETER :: densmin=1.0E03 +! index for Aitken mode number + INTEGER, PARAMETER :: vdnnuc=1 +! index for accumulation mode number + INTEGER, PARAMETER :: vdnacc=2 +! index for coarse mode number + INTEGER, PARAMETER :: vdncor=3 +! index for Aitken mode mass + INTEGER, PARAMETER :: vdmnuc=4 +! index for accumulation mode + INTEGER, PARAMETER :: vdmacc=5 +! index for fine mode mass (Aitken + accumulation) + INTEGER, PARAMETER :: vdmfine=6 +! index for coarse mode mass + INTEGER, PARAMETER :: vdmcor=7 +! index for Aitken mode number + INTEGER, PARAMETER :: vsnnuc=1 +! index for Accumulation mode number + INTEGER, PARAMETER :: vsnacc=2 +! index for coarse mode number + INTEGER, PARAMETER :: vsncor=3 +! index for Aitken mode mass + INTEGER, PARAMETER :: vsmnuc=4 +! index for accumulation mode mass + INTEGER, PARAMETER :: vsmacc=5 +! index for coarse mass + INTEGER, PARAMETER :: vsmcor=6 +! coarse mode exp( log^2( sigmag )/8 ) +! nuclei **4 + REAL(kind_phys) :: esn04 +! accumulation + REAL(kind_phys) :: esa04 + REAL(kind_phys) :: esc04 +! coarse +! nuclei **5 + REAL(kind_phys) :: esn05 + REAL(kind_phys) :: esa05 +! accumulation +! nuclei **8 + REAL(kind_phys) :: esn08 +! accumulation + REAL(kind_phys) :: esa08 + REAL(kind_phys) :: esc08 +! coarse +! nuclei **9 + REAL(kind_phys) :: esn09 + REAL(kind_phys) :: esa09 +! accumulation +! nuclei **12 + REAL(kind_phys) :: esn12 +! accumulation + REAL(kind_phys) :: esa12 + REAL(kind_phys) :: esc12 +! coarse mode +! nuclei **16 + REAL(kind_phys) :: esn16 +! accumulation + REAL(kind_phys) :: esa16 + REAL(kind_phys) :: esc16 +! coarse +! nuclei **20 + REAL(kind_phys) :: esn20 +! accumulation + REAL(kind_phys) :: esa20 + REAL(kind_phys) :: esc20 +! coarse +! nuclei **25 + REAL(kind_phys) :: esn25 + REAL(kind_phys) :: esa25 +! accumulation +! nuclei **24 + REAL(kind_phys) :: esn24 +! accumulation + REAL(kind_phys) :: esa24 + REAL(kind_phys) :: esc24 +! coarse +! nuclei **28 + REAL(kind_phys) :: esn28 +! accumulation + REAL(kind_phys) :: esa28 + REAL(kind_phys) :: esc28 +! coarse +! nuclei **32 + REAL(kind_phys) :: esn32 +! accumulation + REAL(kind_phys) :: esa32 + REAL(kind_phys) :: esc32 +! coarese +! nuclei **36 + REAL(kind_phys) :: esn36 +! accumulation + REAL(kind_phys) :: esa36 + REAL(kind_phys) :: esc36 +! coarse +! nuclei **49 + REAL(kind_phys) :: esn49 + REAL(kind_phys) :: esa49 +! accumulation +! nuclei **52 + REAL(kind_phys) :: esn52 + REAL(kind_phys) :: esa52 +! accumulation +! nuclei **64 + REAL(kind_phys) :: esn64 +! accumulation + REAL(kind_phys) :: esa64 + REAL(kind_phys) :: esc64 +! coarse + REAL(kind_phys) :: esn100 +! nuclei **100 +! nuclei **(-20) + REAL(kind_phys) :: esnm20 +! accumulation + REAL(kind_phys) :: esam20 + REAL(kind_phys) :: escm20 +! coarse +! nuclei **(-32) + REAL(kind_phys) :: esnm32 +! accumulation + REAL(kind_phys) :: esam32 + REAL(kind_phys) :: escm32 +!SAM 10/08 Gaussian quadrature constants for SOA_VBS deposition numerical +!integration + INTEGER, PARAMETER :: NGAUSdv= 7 ! Number of Gaussian Quadrature Points + REAL(kind_phys) :: xxlsgn, xxlsga, xxlsgc + REAL(kind_phys) :: Y_GQ(NGAUSdv), WGAUS(NGAUSdv) +end module dep_data_mod diff --git a/physics/smoke_dust/dep_dry_mod_emerson.F90 b/physics/smoke_dust/dep_dry_mod_emerson.F90 new file mode 100755 index 000000000..e69d6bc3f --- /dev/null +++ b/physics/smoke_dust/dep_dry_mod_emerson.F90 @@ -0,0 +1,361 @@ +!>\file dep_dry_mod.F90 +!! This file is for the dry depostion driver. +!-------------REVISION HISTORY---------------! +! XX/XX/XXXX : original implementation (Ravan Ahmadov) +! 08/17/2023 : modified to follow Emerson et al., (2020) (Jordan Schnell) +! 08/17/2023 : gravitational settling folowing the coarse pm settling driver (Jordan Schnell) + +module dep_dry_emerson_mod + + use machine , only : kind_phys + use dep_data_mod ! JLS + use rrfs_smoke_config, only : num_chem, p_smoke, p_dust_1, p_coarse_pm, n_dbg_lines + + implicit none + + private + + public :: dry_dep_driver_emerson + +contains + subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & + chem,delz,snowh,t_phy,p_phy,rho_phy,ivgtyp,g0,dt, & + settling_flag,drydep_flux,settling_flux,dbg_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, curr_secs, mpiid, xlat, xlong ) +! +! compute dry deposition velocity for aerosol particles +! Based on Emerson et al. (2020), PNAS, +! www.pnas.org/cgi/doi/10.1073/pnas.2014761117 +! Code adapted from Hee-Ryu and Min, (2022): +! https://agupubs.onlinelibrary.wiley.com/doi/epdf/10.1029/2021MS002792 +!---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: settling_flag,ndvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL(kind_phys) :: curr_secs + + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN) :: ustar, rmol, znt, snowh + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: t_phy, rho_phy, p_phy, delz + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: ivgtyp + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL(kind_phys), INTENT(IN) :: g0,dt + LOGICAL, INTENT(IN) :: dbg_opt + ! + ! Output arrays + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, ndvel ), INTENT(INOUT) :: ddvel + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, ndvel), & + INTENT(OUT) :: vgrav + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, ndvel ), INTENT(OUT) :: settling_flux, drydep_flux + ! Local + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) :: aer_res + REAL(kind_phys), DIMENSION( ndvel ) :: cblk + ! Modpar variables, mass, density, diameter, knudsen number, mean free path + REAL(kind_phys) :: pmasssn,pmassa,pmassc,pdensn,pdensa,pdensc, & + dgnuc,dgacc,dgcor,knnuc,knacc,kncor,xlm + real(kind_phys) :: Cc ! Cunningham/slip correction factor [-] + real(kind_phys) :: DDp, Eb ! Brownian diffusion [] + real(kind_phys) :: Eim ! Impaction [] + real(kind_phys) :: Ein ! Interception [] + real(kind_phys) :: Sc ! Schmit number [] + real(kind_phys) :: St ! Stokes number [] + real(kind_phys) :: vg ! gravitational settling [cm/s] + real(kind_phys) :: A, eps0, dumalnsg ! land surface params [-] + real(kind_phys) :: amu, amu_corrected ! dynamic viscosity [g/s] + real(kind_phys) :: airkinvisc ! Air kinetic viscosity [cm2/s] + real(kind_phys) :: freepath ! Air molecular freepath [cm] + real(kind_phys) :: dp ! aerosol diameter [cm] + real(kind_phys) :: aerodens ! aerosol density [g/cm3] + real(kind_phys) :: Rs ! Surface resistance + real(kind_phys) :: vgpart + real(kind_phys) :: growth_fac,vsettl,dtmax,conver,converi,dzmin + real(kind_phys) :: rmol_local + real(kind_phys), dimension( kts:kte) :: rho_col, delz_col + real(kind_phys), dimension(ndvel) :: dt_settl, chem_before, chem_after + real(kind_phys), dimension( kts:kte, ndvel ) :: cblk_col, vg_col + integer, dimension(ndvel) :: ndt_settl + integer :: i, j, k, ntdt, nv + integer :: icall=0 + integer, INTENT(IN) :: mpiid + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong + ! chem pointers (p_*) are not sequentially numbered, need to define so nv loops work + integer, dimension(ndvel) :: chem_pointers +!> -- Gas constant + real(kind_phys), parameter :: RSI = 8.314510 + chem_pointers(1) = p_smoke + chem_pointers(2) = p_dust_1 + chem_pointers(3) = p_coarse_pm + + growth_fac = 1.0 + conver=1.e-9 + converi=1.e9 + + if (mod(int(curr_secs),1800) .eq. 0) then + icall = 0 + endif + + do j = jts, jte + do i = its, ite + aer_res(i,j) = 0.0 + rmol_local = rmol(i,j) + do k = kts, kte + delz_col(k) = delz(i,k,j) + rho_col(k) = rho_phy(i,k,j) + do nv = 1, ndvel + cblk(nv) = chem(i,k,j,chem_pointers(nv)) + if ( k == kts ) then + ddvel(i,j,nv) = 0.0 + dt_settl(nv) = 0.0 + endif ! k==kts + end do ! nv + ! *** U.S. Standard Atmosphere 1962 page 14 expression + ! for dynamic viscosity = beta * T * sqrt(T) / ( T + S) + ! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ]. + amu = 1.458E-6 * t_phy(i,k,j) * sqrt(t_phy(i,k,j)) / ( t_phy(i,k,j) + 110.4 ) + ! Aerodynamic resistance + call depvel( rmol_local, dep_ref_hgt, znt(i,j), ustar(i,j), vgpart, aer_res(i,j) ) + ! depvel uses meters, need to convert to s/cm + aer_res(i,j) = max(aer_res(i,j)/100._kind_phys,0._kind_phys) + ! Air kinematic viscosity (cm^2/s) + airkinvisc = ( 1.8325e-4 * ( 416.16 / ( t_phy(i,k,j) + 120.0 ) ) * & + ( ( t_phy(i,k,j) / 296.16 )**1.5 ) ) / ( rho_phy(i,k,j) / 1.e3 ) ! Convert density to mol/cm^3 + ! Air molecular freepath (cm) ! Check against XLM from above + freepath = 7.39758e-4 * airkinvisc / sqrt( t_phy(i,k,j) ) + do nv = 1, ndvel + if ( chem_pointers(nv) == p_smoke ) then + dp = 4.E-8 !dgacc + aerodens = 1.4e+3 !pdensa + elseif ( chem_pointers(nv) == p_dust_1) then + dp = 1.E-6 !dgacc + aerodens = 2.6e+3 !pdensa + elseif ( chem_pointers(nv) == p_coarse_pm ) then + dp = 4.5E-6 !dgcor + aerodens = 2.6e+3 !pdensc + else + continue + endif + ! Convert diameter to cm and aerodens to g/cm3 + aerodens = aerodens / 1000. + dp = dp * 1e+2 + ! Cunningham correction factor + Cc = 1. + 2. * freepath / dp * ( 1.257 + 0.4*exp( -0.55 * dp / freepath ) ) + ! Corrected dynamic viscosity (used for settling) + amu_corrected = amu / Cc + ! Gravitational Settling + vg = aerodens * dp * dp * gravity * 100. * Cc / & ! Convert gravity to cm/s^2 + ( 18. * airkinvisc * ( rho_phy(i,k,j) / 1.e3 ) ) ! Convert density to mol/cm^3 + ! -- Rest of loop for the surface when deposition velocity needs to be cacluated + if ( k == kts ) then + ! Brownian Diffusion + DDp = ( boltzmann * t_phy(i,k,j) ) * Cc / (3. * pi * airkinvisc * ( rho_phy(i,k,j) / 1.e3 ) * dp) ! Convert density to mol/cm^3 + ! Schmit number + Sc = airkinvisc / DDp + ! Brownian Diffusion + Eb = Cb * Sc**(-0.666666667) + ! Stokes number + St = ( 100. * ustar(i,j) ) * ( 100.* ustar(i,j) ) * vg / airkinvisc / ( gravity * 100.) ! Convert ustar to cm/s, gravity to cm/s^2 + ! Impaction + Eim = Cim * ( St / ( alpha + St ) )**1.7 + ! MODIS type lu, large roughness lengths (e.g., urban or forest) + ! ----------------------------------------------------------------------- + ! *** TO DO -- set A and eps0 for all land surface types *** !!! + ! ----------------------------------------------------------------------- + if ( ivgtyp(i,j) .eq. 13 .or. ivgtyp(i,j) .le. 5 ) then ! Forest + A = A_for + eps0 = eps0_for + else if ( ivgtyp(i,j) .eq. 17 ) then ! water + A = A_wat + eps0 = eps0_wat + else ! otherwise + A = A_grs + eps0 = eps0_grs + end if + ! Set if snow greater than 1 cm + ! Interception + Ein = Cin * ( dp / A )**vv + ! Surface resistance + Rs = 1. / ( ( ustar(i,j) * 100.) * ( Eb + Eim + Ein) * eps0 ) ! Convert ustar to cm/s + ! Compute final ddvel = aer_res + RS, set max at max_dep_vel in dep_data_mod.F[ m/s] + ! The /100. term converts from cm/s to m/s, required for MYNN. + if ( settling_flag == 1 ) then + ddvel(i,j,nv) = max(min( ( vg + 1./(aer_res(i,j)+Rs) )/100., max_dep_vel),0._kind_phys) + else + ddvel(i,j,nv) = max(min( ( 1./(aer_res(i,j)+Rs) )/100., max_dep_vel),0._kind_phys) + endif + if ( dbg_opt .and. (icall .le. n_dbg_lines) ) then + WRITE(1000+mpiid,*) 'dry_dep_mod_emer:xlat,xlong,curr_secs,nv',xlat(i,j),xlong(i,j),int(curr_secs),nv + WRITE(1000+mpiid,*) 'dry_dep_mod_emer:xlat,xlong,curr_secs,deposition velocity (m/s)',xlat(i,j),xlong(i,j),int(curr_secs),ddvel(i,j,nv) + icall = icall + 1 + endif + drydep_flux(i,j,nv) = chem(i,kts,j,chem_pointers(nv))*rho_phy(i,k,j)*ddvel(i,j,nv)/100.0*dt + endif ! k == kts + vgrav(i,k,j,nv) = vg + ! Fill column variables + cblk_col(k,nv) = cblk(nv) + vg_col(k,nv) = vg + enddo ! nv + enddo ! k + ! -- Get necessary info for settling + ! -- Determine the maximum time-step satisying the CFL condition: + dzmin = minval(delz_col) + ntdt=INT(dt) + do nv = 1, ndvel + ! -- NOTE, diameters and densities are NOT converted to cm and g/cm3 like above + ! -- dt_settl calculations (from original coarsepm_settling) + if ( chem_pointers(nv) == p_smoke ) then + dp = 4.E-8 !dgacc + aerodens = 1.4e+3 !pdensa + elseif ( chem_pointers(nv) == p_dust_1) then + dp = 1.E-6 !dgacc + aerodens = 2.6e+3 !pdensa + elseif ( chem_pointers(nv) == p_coarse_pm ) then + dp = 4.5E-6 !dgcor + aerodens = 2.6e+3 !pdensc + else + continue + endif + ! 1.5E-5 = dyn_visc --> dust_data_mod.F90 + vsettl = 2.0 / 9.0 * g0 * aerodens * ( growth_fac * ( 0.5 * dp ))**2.0 / ( 0.5 * 1.5E-5 ) + dtmax = dzmin / vsettl + ndt_settl(nv) = MAX( 1, INT( ntdt /dtmax) ) + ! Limit maximum number of iterations + IF (ndt_settl(nv) > 12) ndt_settl(nv) = 12 + dt_settl(nv) = REAL(ntdt,kind=kind_phys) /REAL(ndt_settl(nv),kind=kind_phys) + enddo + ! Perform gravitational settling if desired + if ( settling_flag == 1 ) then + call particle_settling(cblk_col,rho_col,delz_col,vg_col,dt_settl,ndt_settl,ndvel,kts,kte) + endif + ! Put cblk back into chem array + do nv= 1, ndvel + do k = kts, kte + chem(i,k,j,chem_pointers(nv)) = cblk_col(k,nv) + enddo ! k + enddo ! nv + end do ! j + end do ! i +end subroutine dry_dep_driver_emerson +! +!-------------------------------------------------------------------------------- +! +subroutine depvel( rmol, zr, z0, ustar, 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 +! USTAR - FRICTION VELOCITY U* +! 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. +!-------------------------------------------------- +! .. Scalar Arguments .. +!-------------------------------------------------- + REAL(kind_phys), intent(in) :: ustar, z0, zr + REAL(kind_phys), intent(out) :: vgpart, aer_res + REAL(kind_phys), intent(inout) :: rmol +!-------------------------------------------------- +! .. Local Scalars .. +!-------------------------------------------------- + INTEGER :: l + REAL(kind_phys) :: ao, ar, polint, vk +!-------------------------------------------------- +! .. Intrinsic Functions .. +!-------------------------------------------------- + INTRINSIC alog +!-------------------------------------------------- +! 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 +!-------------------------------------------------- + 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_kind_phys*alog(zr/z0) + 4.7_kind_phys*rmol*(zr-z0) + END IF + vgpart = ustar*vk/polint + aer_res = polint/(karman*max(ustar,1.0e-4)) +end subroutine depvel +! +!-------------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------------- +! +subroutine particle_settling(cblk,rho_phy,delz,vg,dt_settl,ndt_settl,ndvel,kts,kte) + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: kts, kte, ndvel + REAL(kind_phys), DIMENSION(kts:kte), INTENT (IN) :: rho_phy, delz + REAL(kind_phys), DIMENSION(kts:kte,ndvel), INTENT(IN) :: vg + REAL(kind_phys), DIMENSION(kts:kte,ndvel), INTENT(INOUT) :: cblk + REAL(kind_phys), DIMENSION(ndvel), INTENT(IN) :: dt_settl + INTEGER, DIMENSION(ndvel), INTENT(IN) :: ndt_settl +! +!--- Local------ + INTEGER :: k,nv,n,l2 + REAL(kind_phys) :: temp_tc, transfer_to_below_level, vd_wrk1 + REAL(kind_phys), DIMENSION(kts:kte) :: delz_flip + + do k = kts,kte + delz_flip(k) = delz(kte-k+kts) + enddo + + do nv = 1, ndvel + do n = 1,ndt_settl(nv) + transfer_to_below_level = 0.0 + do k = kte,kts,-1 + l2 = kte - k + 1 + + temp_tc = cblk(k,nv) + + vd_wrk1 = dt_settl(nv) * vg(k,nv)/100. / delz_flip(l2) ! convert vg to m/s + + cblk(k,nv)= cblk(k,nv) * (1. - vd_wrk1) + transfer_to_below_level + if (k.gt.kts) then + transfer_to_below_level =(temp_tc*vd_wrk1)*((delz_flip(l2) & + *rho_phy(k))/(delz_flip(l2+1)*rho_phy(k-1))) ! [ug/kg] + endif + enddo ! k + enddo ! n + enddo ! nv +end subroutine particle_settling + +! +end module dep_dry_emerson_mod diff --git a/physics/smoke_dust/dep_dry_mod.F90 b/physics/smoke_dust/dep_dry_simple_mod.F90 similarity index 77% rename from physics/smoke_dust/dep_dry_mod.F90 rename to physics/smoke_dust/dep_dry_simple_mod.F90 index ea7dd9963..e47d3d974 100755 --- a/physics/smoke_dust/dep_dry_mod.F90 +++ b/physics/smoke_dust/dep_dry_simple_mod.F90 @@ -1,7 +1,7 @@ -!>\file dep_dry_mod.F90 +!>\file dep_dry_simple_mod.F90 !! This file is for the dry depostion driver. -module dep_dry_mod +module dep_dry_simple_mod use machine , only : kind_phys @@ -9,11 +9,11 @@ module dep_dry_mod private - public :: dry_dep_driver + public :: dry_dep_driver_simple contains - subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & + subroutine dry_dep_driver_simple(rmol,ust,ndvel,ddvel, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -26,8 +26,6 @@ subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & 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 @@ -56,14 +54,11 @@ subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & 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 subroutine dry_dep_driver_simple -end module dep_dry_mod +end module dep_dry_simple_mod diff --git a/physics/smoke_dust/dust_fengsha_mod.F90 b/physics/smoke_dust/dust_fengsha_mod.F90 index 1e24c8947..6ec8f8d4a 100755 --- a/physics/smoke_dust/dust_fengsha_mod.F90 +++ b/physics/smoke_dust/dust_fengsha_mod.F90 @@ -21,8 +21,8 @@ module dust_fengsha_mod contains subroutine gocart_dust_fengsha_driver(dt, & - chem,rho_phy,smois,p8w,ssm, & - isltyp,vegfra,snowh,xland,area,g,emis_dust, & + chem,rho_phy,smois,stemp,p8w,ssm, & + isltyp,snowh,xland,area,g,emis_dust, & ust,znt,clay,sand,rdrag,uthr, & num_emis_dust,num_chem,num_soil_layers, & ids,ide, jds,jde, kds,kde, & @@ -37,7 +37,6 @@ subroutine gocart_dust_fengsha_driver(dt, & ! 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 @@ -55,7 +54,7 @@ subroutine gocart_dust_fengsha_driver(dt, & 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, num_soil_layers, jms:jme ), INTENT(IN) :: smois, stemp !0d input variables REAL(kind_phys), INTENT(IN) :: dt ! time step @@ -141,15 +140,17 @@ subroutine gocart_dust_fengsha_driver(dt, & endif ! limit where there is lots of vegetation - if (vegfra(i,j) .gt. .17) then - ilwi = 0 - endif ! limit where there is snow on the ground if (snowh(i,j) .gt. 0) then ilwi = 0 endif + ! Don't emit over frozen soil + if (stemp(i,1,j) < 268.0) then ! -5C + 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. & diff --git a/physics/smoke_dust/module_add_emiss_burn.F90 b/physics/smoke_dust/module_add_emiss_burn.F90 index 6cdd2e071..80d91bb0e 100755 --- a/physics/smoke_dust/module_add_emiss_burn.F90 +++ b/physics/smoke_dust/module_add_emiss_burn.F90 @@ -6,217 +6,174 @@ module module_add_emiss_burn use machine , only : kind_phys use rrfs_smoke_config CONTAINS - 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,ext3d_smoke,ext3d_dust, & - ! nwfa,nifa, & - rainc,rainnc, swdown,smoke_forecast, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - -! USE module_configure, only: grid_config_rec_type -! USE module_state_description - IMPLICIT NONE + subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & + chem,julday,gmt,xlat,xlong, & + fire_end_hr, peak_hr,time_int, & + coef_bb_dc, fire_hist, hwp, hwp_prevd, & + swdown,ebb_dcycle, ebu_in, ebu,fire_type,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,mpiid ) -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + IMPLICIT NONE - INTEGER, INTENT(IN ) :: julday, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + INTEGER, INTENT(IN ) :: julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN) :: mpiid real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem + INTENT(INOUT ) :: chem ! shall we set num_chem=1 here? real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN) :: ebu - - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, rainc,rainnc,swdown, peak_hr, vfrac - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: r_q ! RAR: - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist ! RAR: - real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: 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 -! real(kind_phys), DIMENSION(ims:ime,1:nlcat,jms:jme), INTENT(IN) :: luf_igbp - -! real(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & -! OPTIONAL, INTENT(INOUT ) :: nwfa,nifa ! RAR: - - real(kind_phys), INTENT(IN) :: dtstep, gmt - real(kind_phys), INTENT(IN) :: time_int ! RAR: time in seconds since start of simulation - 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 - !real(kind_phys) :: ebumax -! CHARACTER (LEN=80) :: message - - INTEGER, PARAMETER :: kfire_max=51 ! max vertical level for BB plume rise - ! Diameters and standard deviations for emissions - ! the diameters are the volume (mass) geometric mean diameters, following MADE_SORGAM - real(kind_phys), PARAMETER :: dgvem_i= 0.08E-6 !0.03E-6 ! [ m ] - real(kind_phys), PARAMETER :: sgem_i = 1.8 !1.7 - - ! *** Accumulation mode: - real(kind_phys), PARAMETER :: dgvem_j= 0.3E-6 ! [ m ] - real(kind_phys), PARAMETER :: sgem_j = 2.0 - - ! *** Coarse mode - real(kind_phys), PARAMETER :: dgvem_c= 6.0E-6 ! [ m ] - real(kind_phys), PARAMETER :: sgem_c= 2.2 - real(kind_phys), PARAMETER :: pic= 3.14159 - - ! RAR: factors for getting number emissions rate from mass emissions rate following made_sorgam - real(kind_phys), PARAMETER :: fact_numn= 1.e-9*6.0/pic*exp(4.5*log(sgem_i)**2)/dgvem_i**3 ! Aitken mode - real(kind_phys), PARAMETER :: fact_numa= 1.e-9*6.0/pic*exp(4.5*log(sgem_j)**2)/dgvem_j**3 ! accumulation mode - real(kind_phys), PARAMETER :: fact_numc= 1.e-9*6.0/pic*exp(4.5*log(sgem_c)**2)/dgvem_c**3 ! coarse mode - - real(kind_phys), PARAMETER :: dens_oc_aer=1.4e3, dens_ec_aer=1.7e3 ! kg/m3 -! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, cx=2.184936* 3600, timeq_max=3600.*24. ! constants for the diurnal cycle calculations - real(kind_phys), PARAMETER :: ax1=531., cx1=7800. ! For cropland, urban and small fires -! real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3200., const2=100., coef2=10.6712963e-4, cx=2.184936* 3600, timeq_max=3600.*24. - real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. ! New parameters - real(kind_phys), PARAMETER :: sc_me= 4.0, ab_me=0.5 ! m2/g, scattering and absorption efficiency for smoke - -! Parameters used for the wfa and ifa in mp physics per Trude E. (NCAR) -! Water friendly: radius: 0.04 micron, standard deviation: 1.8, kappa (for hygroscopic growth): 0.2, real index of refraction: 1.53, imaginary index of refraction: 1e-7 -! Ice friendly: radius: 0.4 micron, standard deviation: 1.8, kappa : 0.04, real index of refraction: 1.56, imaginary index of refraction: 3e-3 - - ! real, parameter :: cx = 2.184936 * 3600., rinti = 2.1813936e-8 , ax = 2000.6038 - ! bx_bburn = 20.041288 * 3600., RAR: this depends on the vegetation class, location (local time) etc. - real(kind_phys) :: timeq, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation - - timeq= gmt*3600. + real(time_int,4) - timeq= mod(timeq,timeq_max) - -! Main loops to add BB emissions - do j=jts,jte - do i=its,ite - !if( luf_igbp(i,17,j)>0.99 .OR. ebu(i,1,j,p_ebu_smoke) < 1.e-6) cycle ! no BB emissions or water pixels - if( (1.-vfrac (i,j))>0.99 .OR. ebu(i,1,j) < 1.e-6) cycle ! no BB emissions or water pixels - - ! RAR: the decrease in the BB emissions after >18 hrs of forecast, the decrease occurs at night. The decrease occurs at night. - IF (time_int>64800. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.75 ) THEN - fhist(i,j)= 0.75 - ENDIF + INTENT(INOUT ) :: ebu - IF (time_int>129600. .AND. swdown(i,j)<.1 .AND. fhist(i,j)>.5 ) THEN ! After 36 hr forecast - fhist(i,j)= 0.5 - ENDIF + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, swdown + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: hwp, peak_hr, fire_end_hr, ebu_in !RAR: Shall we make fire_end integer? + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: coef_bb_dc ! RAR: + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: hwp_prevd + + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy !,rel_hum + real(kind_phys), INTENT(IN) :: dtstep, gmt + real(kind_phys), INTENT(IN) :: time_int,pi ! RAR: time in seconds since start of simulation + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: fire_type + integer, INTENT(IN) :: ebb_dcycle ! RAR: this is going to be namelist dependent, ebb_dcycle=means + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fire_hist +!>--local + integer :: i,j,k,n,m + integer :: icall=0 + real(kind_phys) :: conv_rho, conv, dm_smoke, dc_hwp, dc_gp, dc_fn !daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 + + INTEGER, PARAMETER :: kfire_max=51 ! max vertical level for BB plume rise + + real(kind_phys) :: timeq, fire_age, age_hr, dt1,dt2,dtm, coef_con ! For BB emis. diurnal cycle calculation + +! For Gaussian diurnal cycle + real(kind_phys), PARAMETER :: sc_factor=1. ! to scale up the wildfire emissions, TBD later + real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., & + coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. +!>-- Fire parameters + real(kind_phys), dimension(1:5), parameter :: avg_fire_dur = (/8.9, 4.2, 3.3, 3.0, 1.4/) + real(kind_phys), dimension(1:5), parameter :: sigma_fire_dur = (/8.7, 6.0, 5.5, 5.2, 2.4/) + + timeq= gmt*3600._kind_phys + real(time_int,4) + timeq= mod(timeq,timeq_max) - IF ( (rainc(i,j) + rainnc(i,j))>=10. .AND. fhist(i,j)>.3 ) THEN ! If it rains more than 1cm, then the BB emissions are reduced - fhist(i,j)= 0.3 - ENDIF -! RAR: Grasslands (29% of ther western HRRR CONUS domain) probably also need to be added below, check this later -! RAR: In the HRRR CONUS domain (western part) crop 11%, 2% cropland/natural vegetation and 0.4% urban of pixels -!.OR. lu_index(i,j)==14) then ! Croplands(12), Urban and Built-Up(13), cropland/natural vegetation (14) mosaic in MODI-RUC vegetation classes +! RAR: Grasslands (29% of ther western HRRR CONUS domain) probably also need to +! be added below, check this later +! RAR: In the HRRR CONUS domain (western part) crop 11%, 2% cropland/natural +! vegetation and 0.4% urban of pixels +!.OR. lu_index(i,j)==14) then ! Croplands(12), Urban and Built-Up(13), +!cropland/natural vegetation (14) mosaic in MODI-RUC vegetation classes ! Peak hours for the fire activity depending on the latitude -! if (xlong(i,j)<-130.) then max_ti= 24.041288* 3600. ! peak at 24 UTC, fires in Alaska -! elseif (xlong(i,j)<-100.) then max_ti= 22.041288* 3600. ! peak at 22 UTC, fires in the western US -! elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US, max_ti= 20.041288* 3600. +! if (xlong(i,j)<-130.) then max_ti= 24.041288* 3600. ! +! peak at 24 UTC, fires in Alaska +! elseif (xlong(i,j)<-100.) then max_ti= 22.041288* 3600. +! ! peak at 22 UTC, fires in the western US +! elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in +! the eastern US, max_ti= 20.041288* 3600. ! else max_ti= 18.041288* 3600. ! endif +! RAR: for option #1 ebb and frp are ingested for 24 hours. No modification is +! applied! + if (ebb_dcycle==1) then + do k=kts,kte + do i=its,ite + ebu(i,k,1)=ebu_in(i,1) ! RAR: + enddo + enddo + endif + + if (ebb_dcycle==2) then + + ! Constants for the fire diurnal cycle calculation + coef_con=1._kind_phys/((2._kind_phys*pi)**0.5_kind_phys) + do j=jts,jte + do i=its,ite + fire_age= time_int + (fire_end_hr(i,j)-1._kind_phys)*3600._kind_phys !One hour delay is due to the latency of the RAVE files + fire_age= MAX(0._kind_phys,fire_age) + + SELECT CASE ( fire_type(i,j) ) !Ag, urban fires, bare land etc. + CASE (1) + ! these fires will have exponentially decreasing diurnal cycle, + coef_bb_dc(i,j) = coef_con*1._kind_phys/(sigma_fire_dur(1) *fire_age) * & + exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2._kind_phys*sigma_fire_dur(1)**2 )) + + IF ( dbg_opt .AND. time_int<5000.) then + WRITE(6,*) 'i,j,peak_hr(i,j) ',i,j,peak_hr(i,j) + WRITE(6,*) 'coef_bb_dc(i,j) ',coef_bb_dc(i,j) + END IF + + CASE (3) + age_hr= fire_age/3600._kind_phys + + IF (swdown(i,j)<.1 .AND. age_hr> 12. .AND. fire_hist(i,j)>0.75) THEN + fire_hist(i,j)= 0.75_kind_phys + ENDIF + IF (swdown(i,j)<.1 .AND. age_hr> 24. .AND. fire_hist(i,j)>0.5) THEN + fire_hist(i,j)= 0.5_kind_phys + ENDIF + IF (swdown(i,j)<.1 .AND. age_hr> 48. .AND. fire_hist(i,j)>0.25) THEN + fire_hist(i,j)= 0.25_kind_phys + ENDIF + + ! this is based on hwp, hourly or instantenous TBD + dc_hwp= hwp(i,j)/ MAX(5._kind_phys,hwp_prevd(i,j)) + dc_hwp= MAX(0._kind_phys,dc_hwp) + dc_hwp= MIN(25._kind_phys,dc_hwp) + + ! RAR: Gaussian profile for wildfires + dt1= abs(timeq - peak_hr(i,j)) + dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. + dtm= MIN(dt1,dt2) + dc_gp = rinti*( ax2 * exp(- dtm**2/(2._kind_phys*cx2**2) ) + const2 - coef2*timeq ) + dc_gp = MAX(0._kind_phys,dc_gp) + + dc_fn = MIN(dc_hwp/dc_gp,3._kind_phys) + coef_bb_dc(i,j) = fire_hist(i,j)* dc_hwp + + IF ( dbg_opt .AND. time_int<5000.) then + WRITE(6,*) 'i,j,fire_hist(i,j),peak_hr(i,j) ', i,j,fire_hist(i,j),peak_hr(i,j) + WRITE(6,*) 'dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) ',dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) + END IF + + CASE DEFAULT + END SELECT + enddo + enddo + endif + + if (mod(int(time_int),1800) .eq. 0) then + icall = 0 + endif + + do j=jts,jte + do i=its,ite + do k=kts,kfire_max + if (ebu(i,k,j)<0.001_kind_phys) cycle + + if (ebb_dcycle==1) then + conv= dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) + elseif (ebb_dcycle==2) then + conv= sc_factor*coef_bb_dc(i,j)*dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) + endif + dm_smoke= conv*ebu(i,k,j) + chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke + chem(i,k,j,p_smoke) = MIN(MAX(chem(i,k,j,p_smoke),0._kind_phys),5.e+3_kind_phys) + + if ( dbg_opt .and. (k==kts .OR. k==kfire_max) .and. (icall .le. n_dbg_lines) ) then + WRITE(1000+mpiid,*) 'add_emiss_burn:xlat,xlong,curr_secs,fire_type,fire_hist,peak_hr', xlat(i,j),xlong(i,j),int(time_int),fire_type(i,j),fire_hist(i,j),peak_hr(i,j) + WRITE(1000+mpiid,*) 'add_emiss_burn:xlat,xlong,curr_secs,coef_bb_dc,ebu',xlat(i,j),xlong(i,j),int(time_int),coef_bb_dc(i,j),ebu(i,k,j) + endif + enddo + icall = icall + 1 + enddo + enddo - !IF ( lu_fire1(i,j)>0.9 ) then !Ag, urban fires, bare land etc. - IF ( vegtype(i,j)==12 .or. vegtype(i,j)==13 ) then !Ag, urban fires, bare land etc. - ! these fires will have exponentially decreasing diurnal cycle, these fires decrease 55% in 2 hours, end in 5 hours - r_q(i,j) = rinti* ax1 * exp(- (time_int**2)/(cx1**2) ) - ELSE - ! RAR: Gaussian profile for wildfires - dt1= abs(timeq - peak_hr(i,j)) - dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. - dtm= MIN(dt1,dt2) - r_q(i,j) = rinti*( ax2 * exp(- dtm**2/(2.*cx2**2) ) + const2 - coef2*timeq ) - ENDIF - - r_q(i,j) = fhist(i,j)* max(0.,r_q(i,j)*timeq_max) - - !IF (swdown(i,j)<.1) THEN - ! r_q(i,j)= MIN(0.5,r_q(i,j)) ! lower BB emissions at night - !ENDIF - - !IF (.NOT. config_flags%bb_dcycle) THEN - !IF (.NOT. bb_dcycle) THEN - ! r_q(i,j)= fhist(i,j) ! no diurnal cycle - !END IF - - !IF (smoke_forecast == 0) THEN - r_q(i,j)= 1. - !END IF - - do k=kts,kfire_max - conv= r_q(i,j)*dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) - - ! RAR: in this case tracer_1 is fire emitted CO - ! conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - ! chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) + ebu(i,k,j,p_ebu_co)*conv_rho - -! dm_oc_bb = conv* ebu(i,k,j,p_ebu_oc) ! Assume that BB primary PM25 is mostly OC, 1.25 is OM/OC ratio -! dm_p25_bb= conv* ebu(i,k,j,p_ebu_pm25) -! dm_ec_bb = conv* ebu(i,k,j,p_ebu_bc) -! dm_smk = conv* ebu(i,k,j,p_ebu_smoke) - !IF (k==kts) THEN ! Partition takes place here to avoid double counting of smold. and flam. BB emiss. - ! C11= (1.-flam_frac(i,j))*r_q(i,j) - !ELSE - ! C11= flam_frac(i,j)*r_q(i,j) - !ENDIF - dm_smoke= conv*ebu(i,k,j) -! print*,'hli dm_smoke',dm_smoke,conv,ebu(i,k,j,p_ebu_smoke) - - chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke - chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) - - ! if ( k==kts ) then - ! 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 ( 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 - - enddo - enddo - enddo - - ext2= sc_me + ab_me - do j=jts,jte - do k=kts,kte - do i=its,ite - - ! Check for NaNs, negative and too large numbers - IF (.NOT. (chem(i,k,j,p_smoke)>=0. .AND. chem(i,k,j,p_smoke)<1.1e+4)) THEN - chem(i,k,j,p_smoke)=1.e-16 - END IF - - 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 ( 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: 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 -! call wrf_debug(15,'nothing done with burn emissions for chem array') -! END SELECT emiss_select END subroutine add_emis_burn END module module_add_emiss_burn + diff --git a/physics/smoke_dust/module_plumerise.F90 b/physics/smoke_dust/module_plumerise.F90 new file mode 100755 index 000000000..5f7ef2a0e --- /dev/null +++ b/physics/smoke_dust/module_plumerise.F90 @@ -0,0 +1,195 @@ +!>\file module_plumerise.F90 +!! This file is the fire plume rise driver. + + module module_plumerise + + use machine , only : kind_phys +! real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) +!- Implementing the fire radiative power (FRP) methodology for biomass burning +!- emissions and convective energy estimation. +!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) +!- Ravan Ahmadov, Georg Grell (NOAA, USA) +!- The flag "plumerise_flag" defines the method: +!- =1 => original method +!- =2 => FRP based + +CONTAINS +subroutine ebu_driver ( flam_frac,ebu_in,ebu, & + theta_phy,q_vap, & ! RAR: moist is replaced with q_vap, SRB: t_phy is repalced by theta_phy + rho_phy,vvel,u_phy,v_phy,pi_phy, & ! SRB: p_phy is replaced by pi_phy + wind_phy, & ! SRB: added wind_phy + z_at_w,z,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags + frp_inst, k_min, k_max, & ! RAR: + wind_eff_opt, & + kpbl_thetav, & ! SRB: added kpbl_thetav + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, errmsg, errflg,curr_secs, & + xlat, xlong , uspdavg2, hpbl_thetav2, mpiid) + + use rrfs_smoke_config + !use plume_data_mod + USE module_zero_plumegen_coms + USE module_smoke_plumerise + IMPLICIT NONE + + REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to distribute smoke in PBL + + REAL(kind_phys), PARAMETER :: zpbl_threshold = 2000. ! SRB: Minimum PBL depth to have plume rise + REAL(kind_phys), PARAMETER :: uspd_threshold = 5. ! SRB: Wind speed averaged across PBL depth to control smoke release levels + REAL(kind_phys), PARAMETER :: frp_threshold500 = 500.e+6 ! SRB: Minimum FRP (Watts) to have plume rise + + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: frp_inst ! RAR: FRP array + + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong ! SRB + + real(kind_phys), DIMENSION(ims:ime, jms:jme), INTENT(IN) :: kpbl_thetav ! SRB + + character(*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(kind_phys) :: curr_secs + INTEGER, INTENT(IN ) :: wind_eff_opt + real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu + real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebu_in + real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac + real(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: z,z_at_w,vvel,u_phy,v_phy,rho_phy,pi_phy,q_vap,theta_phy,wind_phy ! RAR, SRB + +! Local variables... + INTEGER :: nv, i, j, k, kp1, kp2 + INTEGER :: icall=0 + INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread + REAL, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: uspdavg2, hpbl_thetav2 ! SRB + real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev, uspd ! SRB + real(kind=kind_phys) :: dz_plume, cpor, con_rocp, uspdavg ! SRB + +! MPI variables + INTEGER, INTENT(IN) :: mpiid + + cpor =con_cp/con_rd + con_rocp=con_rd/con_cp + + if (mod(int(curr_secs),1800) .eq. 0) then + icall = 0 + endif + + IF ( dbg_opt .and. icall .le. n_dbg_lines) then + WRITE(1000+mpiid,*) 'module_plumerise: its,ite,jts,jte ', its,ite,jts,jte + WRITE(1000+mpiid,*) 'module_plumerise: ims,ime,jms,jme ', ims,ime,jms,jme + WRITE(1000+mpiid,*) 'module_plumerise: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) + END IF + +! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated + !do nv=1,num_ebu + do j=jts,jte + do k=kts,kte + do i=its,ite + ebu(i,k,j)=0. + enddo + enddo + enddo + !enddo + +! For now the flammable fraction is constant, based on the namelist. The next +! step to use LU index and meteorology to parameterize it + do j=jts,jte + do i=its,ite + flam_frac(i,j)= 0. + if (frp_inst(i,j) > frp_threshold) then + flam_frac(i,j)= 0.9 + end if + enddo + enddo + + +! RAR: new FRP based approach +! Haiqin: do_plumerise is added to the namelist options +check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise + do j=jts,jte + do i=its,ite + + do k=kts,kte + u_in(k)= u_phy(i,k,j) + v_in(k)= v_phy(i,k,j) + w_in(k)= vvel(i,k,j) + qv_in(k)= q_vap(i,k,j) + pi_in(k)= pi_phy(i,k,j) + zmid(k)= z(i,k,j)-z_at_w(i,kts,j) + z_lev(k)= z_at_w(i,k,j)-z_at_w(i,kts,j) + rho_phyin(k)= rho_phy(i,k,j) + theta_in(k)= theta_phy(i,k,j) + uspd(k)= wind_phy(i,k,j) ! SRB + enddo + + + IF (dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst(i,j) .ge. frp_threshold) ) then + WRITE(1000+mpiid,*) 'module_plumerise_before:xlat,xlong,curr_secs,ebu(kts),frp_inst',xlat(i,j), xlong(i,j), int(curr_secs),ebu(i,kts,j),frp_inst(i,j) + WRITE(1000+mpiid,*) 'module_plumerise_before:xlat,xlong,curr_secs,u(10),v(10),w(10),qv(10)',xlat(i,j), xlong(i,j),int(curr_secs), u_in(10),v_in(10),w_in(kte),qv_in(10) + END IF + +! RAR: the plume rise calculation step: + CALL plumerise(kte,1,1,1,1,1,1, & + u_in, v_in, w_in, theta_in ,pi_in, & + rho_phyin, qv_in, zmid, z_lev, & + wind_eff_opt, & + frp_inst(i,j), k_min(i,j), & + k_max(i,j), dbg_opt, g, con_cp, & + con_rd, cpor, errmsg, errflg, & + icall, mpiid, xlat(i,j), xlong(i,j), curr_secs ) + if(errflg/=0) return + + kp1= k_min(i,j) + kp2= k_max(i,j) + dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) + +! SRB: Adding condition for overwriting plumerise levels + uspdavg=SUM(uspd(kts:kpbl_thetav(i,j)))/kpbl_thetav(i,j) !Average wind speed within the boundary layer + +! SRB: Adding output + uspdavg2(i,j) = uspdavg + hpbl_thetav2(i,j) = z_lev(kpbl_thetav(i,j)) + + IF ((frp_inst(i,j) .gt. frp_threshold) .AND. (frp_inst(i,j) .le. frp_threshold500) .AND. & + (z_lev(kpbl_thetav(i,j)) .gt. zpbl_threshold) .AND. (wind_eff_opt .eq. 1)) THEN + kp1=1 + IF (uspdavg .ge. uspd_threshold) THEN ! Too windy + kp2=kpbl_thetav(i,j)/3 + ELSE + kp2=kpbl_thetav(i,j) + END IF + dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) + do k=kp1,kp2-1 + ebu(i,k,j)= ebu_in(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume + enddo + ELSE + do k=kp1,kp2-1 + ebu(i,k,j)= flam_frac(i,j)* ebu_in(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume + enddo + ebu(i,kts,j)= (1.-flam_frac(i,j))* ebu_in(i,j) + END IF +! SRB: End modification + + IF ( dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst(i,j) .ge. frp_threshold) ) then + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,k_min(i,j), k_max(i,j) ',xlat(i,j),xlong(i,j),int(curr_secs),kp1,kp2 + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,ebu(kts),frp_inst',xlat(i,j),xlong(i,j),int(curr_secs),ebu(i,kts,j),frp_inst(i,j) + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,u(10),v(10),w(10),qv(10)',xlat(i,j),xlong(i,j),int(curr_secs),u_in(10),v_in(10),w_in(kte),qv_in(10) + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,uspdavg,kpbl_thetav',xlat(i,j),xlong(i,j),int(curr_secs),uspdavg,kpbl_thetav(i,j) + IF ( frp_inst(i,j) .ge. 3.e+9 ) then + WRITE(1000+mpiid,*) 'mod_plumerise_after:High FRP at : xlat,xlong,curr_secs,frp_inst',xlat(i,j),xlong(i,j),int(curr_secs),frp_inst(i,j) + END IF + icall = icall + 1 + END IF +! endif check_frp +! icall = icall + 1 + enddo + enddo + + ENDIF check_pl + +end subroutine ebu_driver + +END module module_plumerise diff --git a/physics/smoke_dust/module_plumerise1.F90 b/physics/smoke_dust/module_plumerise1.F90 deleted file mode 100755 index 3c23faa6a..000000000 --- a/physics/smoke_dust/module_plumerise1.F90 +++ /dev/null @@ -1,214 +0,0 @@ -!>\file module_plumerise1.F90 -!! This file is the fire plume rise driver. - - module module_plumerise1 - - use machine , only : kind_phys - real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) -!- Implementing the fire radiative power (FRP) methodology for biomass burning -!- emissions and convective energy estimation. -!- Saulo Freitas, Gabriel Pereira (INPE/UFJS, Brazil) -!- Ravan Ahmadov, Georg Grell (NOAA, USA) -!- The flag "plumerise_flag" defines the method: -!- =1 => original method -!- =2 => FRP based -!------------------------------------------------------------------------- -! -! use module_zero_plumegen_coms -! integer, parameter :: nveg_agreg = 4 -! integer, parameter :: tropical_forest = 1 -! integer, parameter :: boreal_forest = 2 -! integer, parameter :: savannah = 3 - -! integer, parameter :: grassland = 4 -! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct -! character(len=20), parameter :: veg_name(nveg_agreg) = (/ & -! 'Tropical-Forest', & -! 'Boreal-Forest ', & -! 'Savanna ', & -! 'Grassland ' /) -! character(len=20), parameter :: spc_suf(nveg_agreg) = (/ & -! 'agtf' , & ! trop forest -! 'agef' , & ! extratrop forest -! 'agsv' , & ! savanna -! 'aggr' /) ! grassland - -CONTAINS -subroutine ebu_driver ( 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,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, & - its,ite, jts,jte, kts,kte, errmsg, errflg) - - use rrfs_smoke_config - use plume_data_mod - USE module_zero_plumegen_coms - USE module_smoke_plumerise - IMPLICIT NONE - - REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise - - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme, 2 ), INTENT(IN ) :: plume_frp ! RAR: FRP etc. array - -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - character(*), intent(inout) :: errmsg - integer, intent(inout) :: errflg - 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 ), & -! INTENT(IN ) :: moist - real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu - - real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ebb_smoke - real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: flam_frac - -! real(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme ), & -! INTENT(IN ) :: ebu_in -! real(kind=kind_phys), DIMENSION( ims:ime, jms:jme ), & -! INTENT(IN ) :: & -! mean_fct_agtf,mean_fct_agef,& -! mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & -! firesize_agsv,firesize_aggr - - real(kind=kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: t_phy,z,z_at_w,vvel,u_phy,v_phy,rho_phy,p_phy,q_vap ! RAR - ! real(kind=kind_phys), INTENT(IN ) :: dtstep - -! Local variables... - INTEGER :: nv, i, j, k, kp1, kp2 - INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread - !real(kind_phys), dimension (num_ebu) :: eburn_in - !real(kind_phys), dimension (kte,num_ebu) :: eburn_out - real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev - real(kind=kind_phys) :: dz_plume, cpor, con_rocp - - !INTEGER, PARAMETER :: kfire_max=30 -! real(kind_phys), dimension(nveg_agreg) :: firesize,mean_fct -! real(kind_phys) :: sum, ffirs, ratio -! real(kind_phys),save,dimension(its:ite,jts:jte) :: ffirs -! nspecies=num_ebu -! write(0,*)'plumerise' - -! RAR: -! do j=jts,jte: -! do i=its,ite -! ebu(i,kts,j,p_ebu_smoke)= ebb_smoke(i,j) -! ebu(i,kts,j,p_ebu_no) = ebu_in(i,1,j,p_ebu_in_no) -! ebu(i,kts,j,p_ebu_co) = ebu_in(i,1,j,p_ebu_in_co) -! ebu(i,kts,j,p_ebu_so2) = ebu_in(i,1,j,p_ebu_in_so2) -! ebu(i,kts,j,p_ebu_dms) = ebu_in(i,1,j,p_ebu_in_dms) -! ebu(i,kts,j,p_ebu_oc) = ebu_in(i,1,j,p_ebu_in_oc) -! ebu(i,kts,j,p_ebu_bc) = ebu_in(i,1,j,p_ebu_in_bc) -! ebu(i,kts,j,p_ebu_pm25) = ebu_in(i,1,j,p_ebu_in_pm25) -! ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10) -! enddo -! enddo - cpor =con_cp/con_rd - con_rocp=con_rd/con_cp - - 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 - !endif - -! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated - !do nv=1,num_ebu - do j=jts,jte - do k=kts+1,kte - do i=its,ite - ebu(i,k,j)=0. - enddo - enddo - enddo - !enddo - -! For now the flammable fraction is constant, based on the namelist. The next -! step to use LU index and meteorology to parameterize it - do j=jts,jte - do i=its,ite - flam_frac(i,j)= 0. - if (plume_frp(i,j,1) > frp_threshold) then - flam_frac(i,j)= 0.9 - end if - enddo - enddo - - -! RAR: new FRP based approach -!check_pl: IF (config_flags%plumerise_flag == 2 ) THEN ! if the namelist option is set for plumerise -! Haiqin: plumerise_flag is added to the namelist options -check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise - do j=jts,jte - do i=its,ite - ! k_min(i,j)=0 - ! k_max(i,j)=0 - -! check_frp: if (.NOT.do_plumerise) then ! namelist option -! ebu(i,kts,j)= ebb_smoke(i,j) -! else - - do k=kts,kte - u_in(k)= u_phy(i,k,j) - v_in(k)= v_phy(i,k,j) - w_in(k)= vvel(i,k,j) - qv_in(k)= q_vap(i,k,j) ! RAR: moist(i,k,j,p_qv) - !pi_in(k)= cp*(p_phy(i,k,j)/p1000mb)**rcp - pi_in(k)= con_cp*(p_phy(i,k,j)/p1000mb)**con_rocp - zmid(k)= z(i,k,j)-z_at_w(i,kts,j) - z_lev(k)= z_at_w(i,k,j)-z_at_w(i,kts,j) - rho_phyin(k)= rho_phy(i,k,j) - theta_in(k)= t_phy(i,k,j)/pi_in(k)*con_cp - !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp - enddo - - IF (dbg_opt) then - WRITE(*,*) 'module_plumerise1: i,j ',i,j - WRITE(*,*) 'module_plumerise1: plume_frp(i,j,:) ',plume_frp(i,j,:) - WRITE(*,*) 'module_plumerise1: ebu(i,kts,j) ',ebu(i,kts,j) - WRITE(*,*) 'module_plumerise1: u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) ',u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) - WRITE(*,*) 'module_plumerise1: zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) ',zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) - WRITE(*,*) 'module_plumerise1: t_phy(i,kte,j),pi_in(kte)',t_phy(i,kte,j),pi_in(kte) - END IF - -! RAR: the plume rise calculation step: - CALL plumerise(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), dbg_opt, g, con_cp, & - con_rd, cpor, errmsg, errflg ) - !k_max(i,j), config_flags%debug_chem ) - if(errflg/=0) return - - kp1= k_min(i,j) - kp2= k_max(i,j) - dz_plume= z_at_w(i,kp2,j) - z_at_w(i,kp1,j) - - do k=kp1,kp2-1 - ebu(i,k,j)= flam_frac(i,j)* ebb_smoke(i,j)* (z_at_w(i,k+1,j)-z_at_w(i,k,j))/dz_plume - enddo - ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) - - IF ( dbg_opt ) then - WRITE(*,*) 'module_plumerise1: i,j ',i,j - WRITE(*,*) 'module_plumerise1: k_min(i,j), k_max(i,j) ',k_min(i,j), k_max(i,j) - END IF -! endif check_frp - enddo - enddo - - ENDIF check_pl - -end subroutine ebu_driver - -END module module_plumerise1 diff --git a/physics/smoke_dust/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 index 61be06181..aa45890f4 100755 --- a/physics/smoke_dust/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -14,26 +14,28 @@ module module_smoke_plumerise use machine , only : kind_phys - use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & + !use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std !tropical_forest, boreal_forest, savannah, grassland, & - wind_eff + ! wind_eff USE module_zero_plumegen_coms + USE rrfs_smoke_config, only : n_dbg_lines !real(kind=kind_phys),parameter :: rgas=r_d !real(kind=kind_phys),parameter :: cpor=cp/r_d CONTAINS ! RAR: - subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & -! firesize,mean_fct, & - ! nspecies,eburn_in,eburn_out, & + subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & + wind_eff_opt, & frp_inst,k1,k2, dbg_opt, g, cp, rgas, & - cpor, errmsg, errflg ) + cpor, errmsg, errflg, icall, mpiid, lat, long, curr_secs ) implicit none LOGICAL, INTENT (IN) :: dbg_opt + INTEGER, INTENT (IN) :: wind_eff_opt, mpiid + real(kind_phys), INTENT(IN) :: lat,long, curr_secs ! SRB ! INTEGER, PARAMETER :: ihr_frp=1, istd_frp=2!, imean_fsize=3, istd_fsize=4 ! RAR: @@ -43,6 +45,7 @@ subroutine plumerise(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 (OUT) :: k1,k2 character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -68,10 +71,13 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! integer, parameter :: grassland = 4 ! real(kind=kind_phys), dimension(nveg_agreg) :: firesize,mean_fct - INTEGER, PARAMETER :: wind_eff = 1 - + INTEGER :: wind_eff + INTEGER, INTENT(IN) :: icall type(plumegen_coms), pointer :: coms +! Set wind effect from namelist + wind_eff = wind_eff_opt + ! integer:: iloop !REAL(kind=kind_phys), INTENT (IN) :: convert_smold_to_flam @@ -158,19 +164,11 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & endif burnt_area= max(1.0e4,burnt_area) - IF (dbg_opt) THEN - WRITE(*,*) 'plumerise: m1 ', m1 - WRITE(*,*) 'plumerise: imm, FRP,burnt_area ', imm, FRP,burnt_area - ! WRITE(*,*) 'convert_smold_to_flam ',convert_smold_to_flam - WRITE(*,*) 'plumerise: zcon ', coms%zcon - WRITE(*,*) 'plumerise: zzcon ', coms%zzcon - END IF - - IF (dbg_opt) then - WRITE(*,*) 'plumerise: imm ', imm - WRITE(*,*) 'plumerise: burnt_area ',burnt_area - END IF - + IF ( dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst .ge. frp_threshold) ) THEN + WRITE(1000+mpiid,*) 'inside plumerise: xlat,xlong,curr_secs, m1 ', lat,long, int(curr_secs), m1 + WRITE(1000+mpiid,*) 'inside plumerise: xlat,xlong,curr_secs,imm,FRP,burnt_area ', lat, long, int(curr_secs), imm, FRP,burnt_area + END IF + !- get fire properties (burned area, plume radius, heating rates ...) call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) if(errflg/=0) return @@ -178,8 +176,8 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & !------ generates the plume rise ------ call makeplume (coms,kmt,ztopmax(imm),ixx,imm) - IF (dbg_opt) then - WRITE(*,*) 'plumerise after makeplume: imm,kmt,ztopmax(imm) ',imm,kmt,ztopmax(imm) + IF ( dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst .ge. frp_threshold) ) then + WRITE(1000+mpiid,*) 'inside plumerise after makeplume:xlat,xlong,curr_secs,imm,kmt,ztopmax(imm) ', lat, long, int(curr_secs), imm,kmt, ztopmax(imm) END IF enddo lp_minmax @@ -199,12 +197,12 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! enddo !enddo - IF (dbg_opt) then - WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 - WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi + !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) !WRITE(*,*) 'plumerise after set_flam_vert: eburn_out(:,2) ',eburn_out(:,2) - END IF + !END IF ! enddo lp_veg ! sub-grid vegetation, currently it's aggregated diff --git a/physics/smoke_dust/module_wetdep_ls.F90 b/physics/smoke_dust/module_wetdep_ls.F90 index 87212920b..2ef07e38c 100755 --- a/physics/smoke_dust/module_wetdep_ls.F90 +++ b/physics/smoke_dust/module_wetdep_ls.F90 @@ -3,17 +3,18 @@ module module_wetdep_ls use machine , only : kind_phys - use rrfs_smoke_config, only : p_qc, alpha => wetdep_ls_alpha + use rrfs_smoke_config, only : p_smoke, p_dust_1, p_coarse_pm, p_qc, alpha => wetdep_ls_alpha contains subroutine wetdep_ls(dt,var,rain,moist, & - rho,nchem,num_moist,dz8w,vvel, & + rho,nchem,num_moist,ndvel,dz8w,vvel, & + wetdpr_smoke, wetdpr_dust, wetdpr_coarsepm, & 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, & + integer, intent(in) :: nchem, num_moist, ndvel, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -21,6 +22,8 @@ subroutine wetdep_ls(dt,var,rain,moist, 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(out) :: & + wetdpr_smoke, wetdpr_dust, wetdpr_coarsepm 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 @@ -28,6 +31,16 @@ subroutine wetdep_ls(dt,var,rain,moist, real(kind_phys) :: dvar,factor,clsum integer :: nv,i,j,k,km,kb,kbeg !real(kind_phys), parameter :: alpha = .5 ! scavenging factor + integer, save :: print_alpha = 0 + + wetdpr_smoke =0. + wetdpr_dust =0. + wetdpr_coarsepm=0. + + !if ( print_alpha == 0 ) then + ! write(*,*) 'wetdep_ls, alpha = ',alpha + ! print_alpha = print_alpha + 1 + !endif do nv=1,nchem @@ -68,6 +81,14 @@ subroutine wetdep_ls(dt,var,rain,moist, 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) +! Accumulate diags + if (nv .eq. p_smoke ) then + wetdpr_smoke(i,j) = wetdpr_smoke(i,j) + dvar * rho(i,k,j) / dt + elseif (nv .eq. p_dust_1 ) then + wetdpr_dust(i,j) = wetdpr_dust(i,j) + dvar * rho(i,k,j) / dt + elseif (nv .eq. p_coarse_pm ) then + wetdpr_coarsepm(i,j) = wetdpr_coarsepm(i,j) + dvar * rho(i,k,j) / dt + endif var(i,k,j,nv)=max(1.e-16,var(i,k,j,nv)-dvar) endif enddo diff --git a/physics/smoke_dust/plume_data_mod.F90 b/physics/smoke_dust/plume_data_mod.F90 deleted file mode 100755 index 3d4b21c37..000000000 --- a/physics/smoke_dust/plume_data_mod.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!>\file plume_data_mod.F90 -!! This file contains data for the fire plume rise module. - -module plume_data_mod - - use machine , only : kind_phys - - implicit none - - ! -- FRP parameters - integer, dimension(0:20), parameter :: & - catb = (/ & - 0, & - 2, 1, 2, 1, & !floresta tropical 2 and 4 / extra trop fores 1,3,5 - 2, 3, 3, 3, 3, & !cerrado/woody savanna :6 a 9 - 4, 4, 4, 4, 4, 0, 4, 0, 0, 0, 0 & !pastagem/lavouras: 10 ... - /) - - real(kind=kind_phys), dimension(0:4), parameter :: & - flaming = (/ & - 0.00, & ! - 0.45, & ! % biomass burned at flaming phase : tropical forest igbp 2 and 4 - 0.45, & ! % biomass burned at flaming phase : extratropical forest igbp 1 , 3 and 5 - 0.75, & ! % biomass burned at flaming phase : cerrado/woody savanna igbp 6 to 9 - 0.00 & ! % biomass burned at flaming phase : pastagem/lavoura: igbp 10 a 17 - /) - - real(kind=kind_phys), dimension(0:20), parameter :: & - msize= (/ & - 0.00021, & !0near water,1Evergreen needleleaf,2EvergreenBroadleaf,!3Deciduous Needleleaf,4Deciduous Broadleaf - 0.00021, 0.00021, 0.00021, 0.00021, & !5Mixed forest,6Closed shrublands,7Open shrublands,8Woody savannas,9Savannas, - 0.00023, 0.00022, 0.00022, 0.00022, 0.00029, &! 10Grassland,11Permanent wetlands,12cropland,13'Urban and Built-Up' - 0.00029, 0.00021, 0.00026, 0.00021, 0.00026, &!14cropland/natural vegetation mosaic,15Snow and ice,16Barren or sparsely vegetated - 0.00021, 0.00021, 0.00021, 0.00021, 0.00021, 0.00021 & !17Water,18Wooded Tundra,19Mixed Tundra,20Bare Ground Tundra - /) - - ! -- FRP buffer indices - integer, parameter :: p_frp_hr = 1 - integer, parameter :: p_frp_std = 2 - integer, parameter :: num_frp_plume = 2 - - ! -- plumerise parameters - integer, parameter :: tropical_forest = 1 - integer, parameter :: boreal_forest = 2 - integer, parameter :: savannah = 3 - integer, parameter :: grassland = 4 - integer, parameter :: nveg_agreg = 4 - integer, parameter :: wind_eff = 1 - - public - -end module plume_data_mod diff --git a/physics/smoke_dust/rrfs_smoke_config.F90 b/physics/smoke_dust/rrfs_smoke_config.F90 index 58d4c5846..c20d6e2db 100755 --- a/physics/smoke_dust/rrfs_smoke_config.F90 +++ b/physics/smoke_dust/rrfs_smoke_config.F90 @@ -15,30 +15,32 @@ module rrfs_smoke_config !-- constant paramters real(kind=kind_phys), parameter :: epsilc = 1.e-12 - !-- aerosol module configurations - integer :: chem_opt = 1 + integer :: chem_opt = 1 integer :: kemit = 1 integer :: dust_opt = 5 - integer :: seas_opt = 2 + integer :: seas_opt = 0 ! turn off by default logical :: do_plumerise = .true. integer :: addsmoke_flag = 1 + integer :: smoke_forecast = 1 integer :: plumerisefire_frq=60 + integer :: n_dbg_lines = 3 integer :: wetdep_ls_opt = 1 integer :: drydep_opt = 1 - integer :: coarsepm_settling = 1 - logical :: bb_dcycle = .false. - logical :: aero_ind_fdb = .false. + integer :: pm_settling = 1 + integer :: nfire_types = 5 + integer :: ebb_dcycle = 2 ! 1: read in ebb_smoke(i,24), 2: daily logical :: dbg_opt = .true. - integer :: smoke_forecast = 0 ! 0 read in ebb_smoke(i,24) + logical :: aero_ind_fdb = .false. + logical :: add_fire_heat_flux= .false. + logical :: do_rrfs_sd = .true. +! integer :: wind_eff_opt = 1 + logical :: extended_sd_diags = .false. 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 :: DUST_OPT_FENGSHA = 5 + integer, parameter :: num_moist=2, num_chem=20, num_emis_seas=5, num_emis_dust=5 ! -- hydrometeors integer, parameter :: p_qv=1 @@ -52,41 +54,19 @@ module rrfs_smoke_config integer :: numgas = 0 !-- tracers - integer, parameter :: p_so2=1 - integer, parameter :: p_sulf=2 - integer, parameter :: p_dms=3 - integer, parameter :: p_msa=4 - integer, parameter :: p_p25=5, p_smoke=5 - integer, parameter :: p_bc1=6 - integer, parameter :: p_bc2=7 - integer, parameter :: p_oc1=8 - integer, parameter :: p_oc2=9 - integer, parameter :: p_dust_1=10 - integer, parameter :: p_dust_2=11 - integer, parameter :: p_dust_3=12 - integer, parameter :: p_dust_4=13 - integer, parameter :: p_dust_5=14, p_coarse_pm=14 - integer, parameter :: p_seas_1=15 - integer, parameter :: p_seas_2=16 - integer, parameter :: p_seas_3=17 - integer, parameter :: p_seas_4=18 - integer, parameter :: p_seas_5=19 - integer, parameter :: p_p10 =20 - - integer, parameter :: p_edust1=1,p_edust2=2,p_edust3=3,p_edust4=4,p_edust5=5 - integer, parameter :: p_eseas1=1,p_eseas2=2,p_eseas3=3,p_eseas4=4,p_eseas5=5 - - integer :: p_ho=0,p_h2o2=0,p_no3=0 + integer, parameter :: p_smoke=5 + integer, parameter :: p_dust_1=10 + integer, parameter :: p_dust_2=11 + integer, parameter :: p_dust_3=12 + integer, parameter :: p_dust_4=13 + integer, parameter :: p_dust_5=14, p_coarse_pm=14 + integer, parameter :: p_seas_1=15 + integer, parameter :: p_seas_2=16 + integer, parameter :: p_seas_3=17 + integer, parameter :: p_seas_4=18 + integer, parameter :: p_seas_5=19 - ! constants - real(kind=kind_phys), PARAMETER :: airmw = 28.97 - real(kind=kind_phys), PARAMETER :: mw_so2_aer = 64.066 - real(kind=kind_phys), PARAMETER :: mw_so4_aer = 96.066 - real(kind=kind_phys), parameter :: smw = 32.00 - real(kind=kind_phys), parameter :: mwdry = 28. -! d is the molecular weight of dry air (28.966), w/d = 0.62197, and -! (d - w)/d = 0.37803 -! http://atmos.nmsu.edu/education_and_outreach/encyclopedia/humidity.htm + integer, parameter :: p_edust1=1,p_edust2=2,p_edust3=3,p_edust4=4,p_edust5=5 ! -- fire options ! integer, parameter :: num_plume_data = 1 diff --git a/physics/smoke_dust/rrfs_smoke_postpbl.meta b/physics/smoke_dust/rrfs_smoke_postpbl.meta index 50f7afae7..8d7481ec4 100755 --- a/physics/smoke_dust/rrfs_smoke_postpbl.meta +++ b/physics/smoke_dust/rrfs_smoke_postpbl.meta @@ -1,8 +1,7 @@ [ccpp-table-properties] name = rrfs_smoke_postpbl type = scheme - 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 - + dependencies = dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,dep_dry_mod_emerson.F90,dep_data_mod.F90 ######################################################################## [ccpp-arg-table] name = rrfs_smoke_postpbl_run diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index 7b69fc9e3..3842cba54 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -7,19 +7,20 @@ module rrfs_smoke_wrapper use machine , only : kind_phys use rrfs_smoke_config, only : kemit, dust_opt, seas_opt, do_plumerise, & addsmoke_flag, plumerisefire_frq, wetdep_ls_opt, & - drydep_opt, coarsepm_settling, aero_ind_fdb, & - dbg_opt, smoke_forecast, wetdep_ls_alpha, & + drydep_opt, pm_settling, aero_ind_fdb, ebb_dcycle, & + dbg_opt,smoke_forecast,wetdep_ls_alpha,do_rrfs_sd, & + ebb_dcycle, extended_sd_diags,add_fire_heat_flux, & num_moist, num_chem, num_emis_seas, num_emis_dust, & - DUST_OPT_FENGSHA, p_qv, p_atm_shum, p_atm_cldq, & - p_smoke, p_dust_1, p_coarse_pm, epsilc - use dust_data_mod, only : dust_alpha, dust_gamma, dust_moist_opt, & + p_qv, p_atm_shum, p_atm_cldq, & + p_smoke, p_dust_1, p_coarse_pm, epsilc, n_dbg_lines + use dust_data_mod, only : dust_alpha, dust_gamma, dust_moist_opt, & dust_moist_correction, dust_drylimit_factor - use plume_data_mod, only : p_frp_std, p_frp_hr, num_frp_plume use seas_mod, only : gocart_seasalt_driver use dust_fengsha_mod, only : gocart_dust_fengsha_driver - use dep_dry_mod, only : dry_dep_driver + use dep_dry_simple_mod, only : dry_dep_driver_simple + use dep_dry_emerson_mod, only : dry_dep_driver_emerson use module_wetdep_ls, only : wetdep_ls - use module_plumerise1, only : ebu_driver + use module_plumerise, only : ebu_driver use module_add_emiss_burn, only : add_emis_burn use coarsepm_settling_mod, only : coarsepm_settling_driver @@ -27,13 +28,82 @@ module rrfs_smoke_wrapper private - public :: rrfs_smoke_wrapper_run + public :: rrfs_smoke_wrapper_run, rrfs_smoke_wrapper_init + + integer :: plume_wind_eff contains !>\defgroup rrfs_smoke_wrapper rrfs-sd emission driver Module !> \ingroup gsd_chem_group !! This is the rrfs-sd emission driver Module + +!> \section arg_table_rrfs_smoke_wrapper_init Argument Table +!! \htmlinclude rrfs_smoke_wrapper_init.html +!! + subroutine rrfs_smoke_wrapper_init( seas_opt_in, & ! sea salt namelist + drydep_opt_in, pm_settling_in, & ! Dry Dep namelist + wetdep_ls_opt_in,wetdep_ls_alpha_in, & ! Wet dep namelist + rrfs_sd, do_plumerise_in, plumerisefire_frq_in, & ! smoke namelist + plume_wind_eff_in,add_fire_heat_flux_in, & ! smoke namelist + addsmoke_flag_in, ebb_dcycle_in, smoke_forecast_in, & ! Smoke namelist + dust_opt_in, dust_alpha_in, dust_gamma_in, & ! Dust namelist + dust_moist_opt_in, & ! Dust namelist + dust_moist_correction_in, dust_drylimit_factor_in, & ! Dust namelist + aero_ind_fdb_in, & ! Feedback namelist + extended_sd_diags_in,dbg_opt_in, & ! Other namelist + errmsg, errflg, n_dbg_lines_in ) + + +!>-- Namelist + real(kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in + real(kind_phys), intent(in) :: dust_moist_correction_in + real(kind_phys), intent(in) :: dust_drylimit_factor_in + integer, intent(in) :: dust_opt_in,dust_moist_opt_in, wetdep_ls_opt_in, pm_settling_in, seas_opt_in + integer, intent(in) :: drydep_opt_in + logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in, extended_sd_diags_in, add_fire_heat_flux_in + integer, intent(in) :: smoke_forecast_in, plume_wind_eff_in, plumerisefire_frq_in, n_dbg_lines_in + integer, intent(in) :: addsmoke_flag_in, ebb_dcycle_in + logical, intent(in) :: do_plumerise_in, rrfs_sd + character(len=*),intent(out):: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + +!>-- Assign namelist values + !>-Dust + dust_alpha = dust_alpha_in + dust_gamma = dust_gamma_in + dust_moist_opt = dust_moist_opt_in + dust_moist_correction = dust_moist_correction_in + dust_drylimit_factor = dust_drylimit_factor_in + dust_opt = dust_opt_in + !>-Sea Salt + seas_opt = seas_opt_in + !>-Dry and wet deposition + drydep_opt = drydep_opt_in + pm_settling = pm_settling_in + wetdep_ls_opt = wetdep_ls_opt_in + wetdep_ls_alpha = wetdep_ls_alpha_in + !>-Smoke + do_rrfs_sd = rrfs_sd + ebb_dcycle = ebb_dcycle_in + do_plumerise = do_plumerise_in + plumerisefire_frq = plumerisefire_frq_in + addsmoke_flag = addsmoke_flag_in + smoke_forecast = smoke_forecast_in + plume_wind_eff = plume_wind_eff_in + add_fire_heat_flux = add_fire_heat_flux_in + !>-Feedback + aero_ind_fdb = aero_ind_fdb_in + !>-Other + extended_sd_diags = extended_sd_diags_in + dbg_opt = dbg_opt_in + n_dbg_lines = n_dbg_lines_in + + end subroutine rrfs_smoke_wrapper_init + !! \section arg_table_rrfs_smoke_wrapper_run Argument Table !! \htmlinclude rrfs_smoke_wrapper_run.html !! @@ -42,148 +112,129 @@ module rrfs_smoke_wrapper 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, con_fv, & - dust12m_in, emi_in, smoke_RRFS, ntrac, qgrs, gq0, chem3d, tile_num, & + nsoil, smc, tslb, vegtype_dom, vegtype_frac, soiltyp, nlcat, & + dswsfc, zorl, snow, julian,recmol, & + idat, rain_cpl, rainc_cpl, hf2d, g, pi, con_cp, con_rd, con_fv, & + dust12m_in, emi_ant_in, smoke_RRFS, smoke2d_RRFS, & + ntrac, qgrs, gq0, chem3d, tile_num, & ntsmoke, ntdust, ntcoarsepm, 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_moist_opt_in, dust_moist_correction_in, dust_drylimit_factor_in, & - dust_alpha_in, dust_gamma_in, fire_in, & - seas_opt_in, dust_opt_in, drydep_opt_in, coarsepm_settling_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) - + nwfa, nifa, emanoc, emdust, emseas, drydep_flux_out, wetdpr, & + ebb_smoke_in, frp_output, coef_bb, fire_type_out, & + ebu_smoke,fhist,min_fplume, & + max_fplume, hwp, hwp_ave, wetness, ndvel, ddvel_inout, & + peak_hr_out,lu_nofire_out,lu_qfire_out, & + fire_heat_flux_out, frac_grid_burned_out, kpbl,oro, & + uspdavg, hpbl_thetav, mpicomm, mpirank, mpiroot, errmsg,errflg ) + implicit none integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) - integer, intent(in) :: ntrac, ntsmoke, ntdust, ntcoarsepm, ndvel + integer, intent(in) :: ntrac, ntsmoke, ntdust, ntcoarsepm, ndvel, nlcat real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd, con_fv - 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 integer, parameter :: its=1,jts=1,jte=1, kts=1 - 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_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, & - rain_cpl, rainc_cpl, hf2d, t2m, dpt2m - real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & - us3d, vs3d, spechum, exch, w + integer, dimension(:), intent(in) :: land, vegtype_dom, soiltyp + real(kind_phys), dimension(:,:), intent(in) :: smc, tslb + real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in + real(kind_phys), dimension(:,:,:), intent(in) :: smoke_RRFS + real(kind_phys), dimension(:,:), intent(in) :: smoke2d_RRFS + real(kind_phys), dimension(:,:), intent(in) :: emi_ant_in + real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & + recmol, garea, rlat,rlon, tskin, pb2d, zorl, snow, & + rain_cpl, rainc_cpl, hf2d, t2m, dpt2m + real(kind_phys), dimension(:,:), intent(in) :: vegtype_frac + real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d + real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, us3d, vs3d, spechum, w real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs, gq0 real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d - real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc - real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr - real(kind_phys), dimension(:), intent(inout) :: coef_bb, fhist - real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke - real(kind_phys), dimension(:,:), intent(inout) :: 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_phys), dimension(:), intent(in) :: wetness - real(kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in - real(kind_phys), intent(in) :: dust_moist_correction_in - real(kind_phys), intent(in) :: dust_drylimit_factor_in - integer, intent(in) :: dust_moist_opt_in - integer, intent(in) :: imp_physics, imp_physics_thompson - integer, intent(in) :: seas_opt_in, dust_opt_in, drydep_opt_in, & - coarsepm_settling_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 - + real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc + real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_in,coef_bb, frp_output, fhist + real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke + real(kind_phys), dimension(:), intent(out ) :: fire_heat_flux_out, frac_grid_burned_out + real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume, uspdavg, hpbl_thetav + real(kind_phys), dimension(:), intent(inout) :: hwp, peak_hr_out + real(kind_phys), dimension(:), intent(inout) :: hwp_ave + real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa + real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout + real(kind_phys), dimension(:,:), intent(inout) :: drydep_flux_out + real(kind_phys), dimension(:,:), intent(inout) :: wetdpr + real(kind_phys), dimension(:), intent(in) :: wetness + real(kind_phys), dimension(:), intent(out) :: lu_nofire_out,lu_qfire_out + integer, dimension(:), intent(out) :: fire_type_out + integer, intent(in) :: imp_physics, imp_physics_thompson + integer, dimension(:), intent(in) :: kpbl + real(kind_phys), dimension(:), intent(in) :: oro + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!>-- Local Variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ebu real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & - p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, zmid, exch_h - - real(kind_phys), dimension(ims:im, jms:jme) :: u10, v10, ust, tsk, & - xland, xlat, xlong, dxy, pbl, hfx, rcav, rnav - + p_phy,pi_phy,wind_phy,theta_phy,z_at_w, dz8w, p8w, t8w, & + rho_phy, vvel, zmid + real(kind_phys), dimension(ims:im, jms:jme) :: frp_inst, u10, v10, ust, tsk, & + xland, xlat, xlong, dxy, pbl, hfx, rnav, hwp_local, & + wetdpr_smoke_local, wetdpr_dust_local, wetdpr_coarsepm_local !>- sea salt & chemistry variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem real(kind_phys), dimension(ims:im, 1, jms:jme, 1:num_emis_seas ) :: emis_seas real(kind_phys), dimension(ims:im, jms:jme) :: seashelp - +!>-- indexes, time integer :: ide, ime, ite, kde, julday - + real(kind_phys) :: gmt !>- dust & chemistry variables real(kind_phys), dimension(ims:im, jms:jme) :: ssm, rdrag, uthr, snowh ! fengsha dust - real(kind_phys), dimension(ims:im, jms:jme) :: vegfrac, rmol, swdown, znt, clayf, sandf - real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois + real(kind_phys), dimension(ims:im, jms:jme) :: rmol, swdown, znt, clayf, sandf + real(kind_phys), dimension(ims:im, nlcat, jms:jme) :: vegfrac + real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois, stemp real(kind_phys), dimension(ims:im, 1:1, jms:jme, 1:num_emis_dust) :: emis_dust integer, dimension(ims:im, jms:jme) :: isltyp, ivgtyp - !>- plume variables ! -- buffers - real(kind_phys), dimension(ims:im, jms:jme) :: ebu_in - real(kind_phys), dimension(ims:im, jms:jme, num_frp_plume ) :: plume_frp - real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, & - fire_hist, peak_hr - real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: ext3d_smoke, ext3d_dust - integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 - logical :: call_fire + real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, frp_in, & + fire_hist, peak_hr, lu_nofire, lu_qfire, ebu_in, & + fire_end_hr, hwp_day_avg, kpbl_thetav,& + uspdavg2, hpbl_thetav2 + integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2, fire_type + logical :: call_plume, reset_hwp_ave, avg_hwp_ave !>- optical variables - real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum - real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel - + real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel, settling_flux, drydep_flux_local + real(kind_phys), dimension(ims:im, kms:kme, jms:jme, ndvel) :: vgrav !>-- anthropogentic variables real(kind_phys), dimension(ims:im) :: emis_anoc real(kind_phys), dimension(ims:im, jms:jme, 1) :: sedim - - real(kind_phys) :: gmt - !> -- parameter to caluclate wfa&ifa (m) real(kind_phys), parameter :: mean_diameter1= 4.E-8, sigma1=1.8 real(kind_phys), parameter :: mean_diameter2= 1.E-6, sigma2=1.8 - real(kind_phys), parameter :: kappa_oc = 0.2 - real(kind_phys), parameter :: kappa_dust = 0.04 real(kind_phys) :: fact_wfa, fact_ifa !> -- aerosol density (kg/m3) real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 - real(kind_phys), dimension(im) :: daero_emis_wfa, daero_emis_ifa -!>-- local variables +!> -- other real(kind_phys), dimension(im) :: wdgust, snoweq integer :: current_month, current_hour, hour_int real(kind_phys) :: curr_secs real(kind_phys) :: factor, factor2, factor3 integer :: nbegin, nv integer :: i, j, k, kp, n +! MPI variables + integer :: mpiid + integer, intent(in) :: mpicomm + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + + mpiid = mpirank 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 - drydep_opt = drydep_opt_in - do_plumerise = do_plumerise_in - plumerisefire_frq = plumerisefire_frq_in - addsmoke_flag = addsmoke_flag_in - smoke_forecast = smoke_forecast_in - aero_ind_fdb = aero_ind_fdb_in - dbg_opt = dbg_opt_in - wetdep_ls_opt = wetdep_ls_opt_in - wetdep_ls_alpha = wetdep_ls_alpha_in - coarsepm_settling = coarsepm_settling_in + if (.not. do_rrfs_sd) return ! -- set domain ide=im @@ -193,22 +244,24 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, min_fplume2 = 0 max_fplume2 = 0 + uspdavg2 = 0. + hpbl_thetav2 = 0. emis_seas = 0. emis_dust = 0. peak_hr = 0. + fire_type = 0 + lu_qfire = 0. + lu_nofire = 0. flam_frac = 0. - ext3d_smoke = 0. - ext3d_dust = 0. daero_emis_wfa = 0. daero_emis_ifa = 0. - rcav = 0. rnav = 0. curr_secs = ktau * dt 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 + hour_int=floor(ktau*dt/3600.) ! hours since the simulation start gmt = real(mod(idat(5)+hour_int,24)) julday = int(julian) @@ -220,70 +273,49 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! -- compute incremental convective and large-scale rainfall do i=its,ite - rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm +! coef_bb initializes as clear_val (from GFS_typedefs.F90) +! at ktau = 1, coef_bb_dc is set = 1.0 coef_bb_dc(i,1) = coef_bb(i) +! fhist initializes as 1. (from GFS_typedefs.F90) fire_hist (i,1) = fhist (i) + peak_hr (i,1) = peak_hr_out(i) enddo + ! Is this a reset timestep (00:00 + dt)? + reset_hwp_ave = mod(int(curr_secs-dt),3600) == 0 + avg_hwp_ave = mod(int(curr_secs),3600) == 0 ! plumerise frequency in minutes set up by the namelist input - 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) + call_plume = (do_plumerise .and. (plumerisefire_frq > 0)) + if (call_plume) call_plume = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) .or. (ktau == 2) !>- get ready for chemistry run call rrfs_smoke_prep( & - current_month, current_hour, gmt, con_rd, con_fv, & + ktau,current_month, current_hour, gmt, con_rd, con_fv, con_cp, & 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_RRFS, & - hf2d, pb2d, g, pi, hour_int, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, & + nsoil,smc,tslb,vegtype_dom,soiltyp, & + nlcat,vegtype_frac,dswsfc,zorl, & + snow,dust12m_in,emi_ant_in,smoke_RRFS,smoke2d_RRFS,coef_bb_dc, & + hf2d, pb2d, g, pi, hour_int, peak_hr, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & - rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,exch_h, & + rri,t_phy,u_phy,v_phy,p_phy,pi_phy,wind_phy,theta_phy, & + rho_phy,dz8w,p8w,t8w,recmol, & z_at_w,vvel,zmid, & ntrac,gq0, & num_chem,num_moist, & ntsmoke, ntdust,ntcoarsepm, & - moist,chem,plume_frp,ebu_in, & - ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & - smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & - snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & + moist,chem,ebu_in,kpbl_thetav,ebb_smoke_in, & + fire_hist,frp_in, hwp_day_avg, fire_end_hr, & + emis_anoc,smois,stemp,ivgtyp,isltyp,vegfrac,rmol,swdown,znt, & + hfx,pbl,snowh,clayf,rdrag,sandf,ssm,uthr,oro, hwp_local, & + t2m,dpt2m,wetness,kpbl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - -! Make this global, calculate at 1st time step only -!>-- for plumerise -- + its,ite, jts,jte, kts,kte ) - 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)<230.) then - peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska - elseif(xlong(i,j)<245.) then - peak_hr(i,j)= 23.0* 3600. - 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)<275.) then - peak_hr(i,j)= 21.0* 3600. - 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 - ENDIF - - IF (ktau==1) THEN + IF (ktau==1) THEN ebu = 0. do j=jts,jte do i=its,ite @@ -293,18 +325,43 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, enddo enddo enddo - ELSE + ELSE do k=kts,kte do i=its,ite - ebu(i,k,1)=ebu_smoke(i,k) + ! ebu is divided by coef_bb_dc since it is applied in the output + ebu(i,k,1)=ebu_smoke(i,k) / coef_bb_dc(i,1) enddo enddo - ENDIF + ENDIF +!RAR: change this to the fractional LU type; fire_type: 0- no fires, 1- Ag +! or urban fires, 2- prescribed fires in wooded area, 3- wildfires + if (ebb_dcycle==2) then + do j=jts,jte + do i=its,ite + if (ebu_in(i,j)<0.01) then + fire_type(i,j) = 0 + lu_nofire(i,j) = 1.0 + else + ! Permanent wetlands, snow/ice, water, barren tundra + lu_nofire(i,j) = vegfrac(i,11,j) + vegfrac(i,15,j) + vegfrac(i,17,j) + vegfrac(i,20,j) + ! cropland, urban, cropland/natural mosaic, barren and sparsely vegetated + lu_qfire(i,j) = vegfrac(i,12,j) + vegfrac(i,13,j) + vegfrac(i,14,j) + vegfrac(i,16,j) + if (lu_nofire(i,j)>0.95) then + fire_type(i,j) = 0 + else if (lu_qfire(i,j)>0.95) then + fire_type(i,j) = 1 + else + fire_type(i,j) = 3 ! RAR: need to add another criteria for fire_type=2, i.e. prescribed fires + end if + end if + end do + end do + endif !>- compute sea-salt - ! -- compute sea salt (opt=2) - if (seas_opt == 2) then + ! -- compute sea salt (opt=1) + if (seas_opt == 1) then call gocart_seasalt_driver(dt,rri,t_phy, & u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & xland,xlat,xlong,dxy,g,emis_seas,pi, & @@ -315,15 +372,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, endif !-- compute dust (opt=5) - if (dust_opt==DUST_OPT_FENGSHA) then - ! Set at compile time in dust_data_mod: - dust_alpha = dust_alpha_in - dust_gamma = dust_gamma_in - dust_moist_opt = dust_moist_opt_in - dust_moist_correction = dust_moist_correction_in - dust_drylimit_factor = dust_drylimit_factor_in - call gocart_dust_fengsha_driver(dt,chem,rho_phy,smois,p8w,ssm, & - isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & + if (dust_opt==1) then + call gocart_dust_fengsha_driver(dt,chem,rho_phy, & + smois,stemp,p8w,ssm, & + isltyp,snowh,xland,dxy,g,emis_dust,ust,znt, & clayf,sandf,rdrag,uthr, & num_emis_dust,num_chem,nsoil, & ids,ide, jds,jde, kds,kde, & @@ -337,35 +389,59 @@ 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_fire) then + if (add_fire_heat_flux) then + WRITE(1000+mpiid,*) 'Entered add_fire_heat_flux at timestep:',ktau + do i = its,ite + if ( coef_bb_dc(i,1)*frp_in(i,1) .ge. 1.E7 ) then + fire_heat_flux_out(i) = min(max(0.,0.88*coef_bb_dc(i,1)*frp_in(i,1) / & + 0.55/dxy(i,1)) ,5000.) ! JLS - W m-2 [0 - 10,000] + frac_grid_burned_out(i) = min(max(0., 1.3*0.0006*coef_bb_dc(i,1)*frp_in(i,1)/dxy(i,1) ),1.) + else + fire_heat_flux_out(i) = 0.0 + frac_grid_burned_out(i) = 0.0 + endif + enddo + endif + if (call_plume) then + ! Apply the diurnal cycle coefficient to frp_inst () + do j=jts,jte + do i=its,ite + frp_inst(i,j) = frp_in(i,j)*coef_bb_dc(i,j) + enddo + enddo + call ebu_driver ( & - flam_frac,ebu_in,ebu, & - t_phy,moist(:,:,:,p_qv), & - rho_phy,vvel,u_phy,v_phy,p_phy, & + flam_frac,ebu_in,ebu, & + theta_phy,moist(:,:,:,p_qv), & + rho_phy,vvel,u_phy,v_phy,pi_phy,wind_phy, & z_at_w,zmid,g,con_cp,con_rd, & - plume_frp, min_fplume2, max_fplume2, & ! new approach + frp_inst, min_fplume2, max_fplume2, & + plume_wind_eff, & + kpbl_thetav, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, errmsg, errflg ) + its,ite, jts,jte, kts,kte, errmsg, errflg, curr_secs, & + xlat, xlong, uspdavg2, hpbl_thetav2, mpiid ) if(errflg/=0) return end if ! -- add biomass burning emissions at every timestep if (addsmoke_flag == 1) then - 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,ext3d_smoke,ext3d_dust, & - rcav, rnav,swdown,smoke_forecast, & + call add_emis_burn(dt,dz8w,rho_phy,pi, & + chem,julday,gmt,xlat,xlong, & + fire_end_hr, peak_hr,curr_secs, & + coef_bb_dc,fire_hist,hwp_local,hwp_day_avg, & + swdown,ebb_dcycle,ebu_in,ebu,fire_type, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte , mpiid ) endif - !>-- compute coarsepm setting - if (coarsepm_settling == 1) then - call coarsepm_settling_driver(dt,t_phy,rel_hum, & + !>-- compute coarsepm setting if using simple dry dep option and + ! pm_settling is on. This is necessary becasue the simple scheme + ! does not have an explicty settling routine, Emersion (opt=1) does. + if (drydep_opt == 2 .and. pm_settling == 1) then + call coarsepm_settling_driver(dt,t_phy, & chem(:,:,:,p_coarse_pm), & rho_phy,dz8w,p8w,p_phy,sedim, & dxy,g,1, & @@ -373,18 +449,29 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif - !>-- compute dry deposition + !>-- compute dry deposition, based on Emerson et al., (2020) if (drydep_opt == 1) then - - call dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & + call dry_dep_driver_emerson(rmol,ust,znt,ndvel,ddvel, & + vgrav,chem,dz8w,snowh,t_phy,p_phy,rho_phy,ivgtyp,g,dt, & + pm_settling,drydep_flux_local,settling_flux,dbg_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - + its,ite, jts,jte, kts,kte, curr_secs, mpiid, xlat, xlong ) do nv=1,ndvel - do i=its,ite - ddvel_inout(i,nv)=ddvel(i,1,nv) + do i=its,ite + ddvel_inout(i,nv)=ddvel(i,1,nv) + enddo enddo + !>-- compute dry deposition based on simple parameterization (HRRR-Smoke) + elseif (drydep_opt == 2) then + call dry_dep_driver_simple(rmol,ust,ndvel,ddvel, & + 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. @@ -392,35 +479,57 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- 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) + call wetdep_ls(dt,chem,rnav,moist, & + rho_phy,num_chem,num_moist,ndvel, dz8w,vvel,& + wetdpr_smoke_local, wetdpr_dust_local, & + wetdpr_coarsepm_local, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + if ( extended_sd_diags .or. dbg_opt) then + do i = its, ite + wetdpr(i,1) = wetdpr(i,1) + wetdpr_smoke_local (i,1) + wetdpr(i,2) = wetdpr(i,2) + wetdpr_dust_local (i,1) + wetdpr(i,3) = wetdpr(i,3) + wetdpr_coarsepm_local(i,1) + enddo + endif endif +! Smoke emisisons diagnostic, RAR: let's multiply by coef_bb_dc before output +! Since ebu_smoke includes coef_bb_dc, we need to divide by coef_bb_dc when it +! comes back into the wrapper. do k=kts,kte do i=its,ite - ebu_smoke(i,k)=ebu(i,k,1) + ebu_smoke(i,k)=ebu(i,k,1) * coef_bb_dc(i,1) enddo enddo - !---- diagnostic output of hourly wildfire potential (07/2021) + if (ktau == 1 .or. reset_hwp_ave) then + hwp_ave = 0. + endif hwp = 0. do i=its,ite - 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) = ext3d_smoke(i,k,1) - dust_ext (i,k) = ext3d_dust (i,k,1) - enddo + hwp(i)=hwp_local(i,1) + hwp_ave(i) = hwp_ave(i) + hwp(i)*dt + if ( ktau == 1) then + hwp_ave(i) = hwp_ave(i) / dt + elseif ( avg_hwp_ave ) then + hwp_ave(i) = hwp_ave(i) / 3600._kind_phys + endif enddo + + +!---- diagnostic output of dry deposition & gravitational settling fluxes + if ( drydep_opt == 1 .and. (extended_sd_diags .or. dbg_opt) ) then + do nv = 1, ndvel + do i=its,ite + drydep_flux_out(i,nv) = drydep_flux_out(i,nv) + & + drydep_flux_local(i,1,nv) !+ & + !settling_flux(i,1,nv) + enddo + enddo + endif !------------------------------------- !---- put smoke stuff back into tracer array do k=kts,kte @@ -444,20 +553,23 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !------------------------------------- !-- to output for diagnostics do i = 1, im +! RAR: let's remove the seas and ant. OC emseas (i) = emis_seas(i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s + emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s emdust (i) = emis_dust(i,1,1,1) + emis_dust(i,1,1,2) + & emis_dust(i,1,1,3) + emis_dust(i,1,1,4) ! dust emission: ug/m2/s - emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s coef_bb (i) = coef_bb_dc(i,1) + frp_output (i) = coef_bb_dc(i,1)*frp_in(i,1) fhist (i) = fire_hist (i,1) min_fplume (i) = real(min_fplume2(i,1)) max_fplume (i) = real(max_fplume2(i,1)) - emseas (i) = sandf(i,1) ! sand for dust - emanoc (i) = uthr (i,1) ! u threshold for dust + fire_type_out(i)=fire_type(i,1) + lu_nofire_out(i)=lu_nofire(i,1) + lu_qfire_out (i)=lu_qfire(i,1) enddo do i = 1, im - fire_in(i,10) = peak_hr(i,1) + peak_hr_out(i) = peak_hr(i,1) enddo !-- to provide real aerosol emission for Thompson MP @@ -489,46 +601,51 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, end subroutine rrfs_smoke_wrapper_run - subroutine rrfs_smoke_prep( & - current_month,current_hour,gmt,con_rd,con_fv, & - 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_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, & - ntsmoke, ntdust, ntcoarsepm, & - moist,chem,plume_frp,ebu_in, & - ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & - smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & - snowh,clayf,rdrag,sandf,ssm,uthr,rel_hum, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + subroutine rrfs_smoke_prep( & + ktau,current_month,current_hour,gmt,con_rd,con_fv,con_cp, & + u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & + pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, & + nsoil,smc,tslb,vegtype_dom,soiltyp,nlcat,vegtype_frac,dswsfc,zorl, & + snow_cpl,dust12m_in,emi_ant_in,smoke_RRFS,smoke2d_RRFS,coef_bb_dc, & + hf2d, pb2d, g, pi, hour_int, peak_hr, & + u10,v10,ust,tsk,xland,xlat,xlong,dxy, & + rri,t_phy,u_phy,v_phy,p_phy,pi_phy,wind_phy,theta_phy, & + rho_phy,dz8w,p8w,t8w,recmol, & + z_at_w,vvel,zmid, & + ntrac,gq0, & + num_chem, num_moist, & + ntsmoke, ntdust, ntcoarsepm, & + moist,chem,ebu_in,kpbl_thetav,ebb_smoke_in, & + fire_hist,frp_in, hwp_day_avg, fire_end_hr, & + emis_anoc,smois,stemp,ivgtyp,isltyp,vegfrac,rmol,swdown, & + znt,hfx,pbl,snowh,clayf,rdrag,sandf,ssm,uthr,oro,hwp_local, & + t2m,dpt2m,wetness,kpbl, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) !Chem input configuration - integer, intent(in) :: current_month, current_hour, hour_int + integer, intent(in) :: current_month, current_hour, hour_int, nlcat !FV3 input variables - integer, intent(in) :: nsoil - integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp + integer, intent(in) :: nsoil, ktau + integer, dimension(ims:ime), intent(in) :: land, vegtype_dom, soiltyp, kpbl integer, intent(in) :: ntrac - real(kind=kind_phys), intent(in) :: g, pi, gmt, con_rd, con_fv + real(kind=kind_phys), intent(in) :: g, pi, gmt, con_rd, con_fv, con_cp 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 + u10m, v10m, ustar, garea, rlat, rlon, ts2d, dswsfc, & + zorl, snow_cpl, pb2d, hf2d, oro, t2m, dpt2m, wetness, recmol + real(kind=kind_phys), dimension(ims:ime, nlcat), intent(in) :: vegtype_frac + real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc,tslb 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_RRFS - real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_in + real(kind=kind_phys), dimension(ims:ime, 24, 2), intent(in) :: smoke_RRFS +! This is a place holder for ebb_dcycle == 2, currently set to hold a single +! value, which is the previous day's average of hwp, frp, ebb, fire_end + real(kind=kind_phys), dimension(ims:ime, 4), intent(in) :: smoke2d_RRFS + real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_ant_in real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & - phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w + phl3d,tk3d,prl3d,us3d,vs3d,spechum,w real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 @@ -540,53 +657,60 @@ subroutine rrfs_smoke_prep( & real(kind_phys), dimension(ims:ime, jms:jme),intent(out) :: ebu_in - real(kind_phys), dimension(ims:ime, jms:jme, num_frp_plume), intent(out) :: plume_frp integer,dimension(ims:ime, jms:jme), intent(out) :: isltyp, ivgtyp real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, & - zmid, exch_h, rel_hum + zmid, pi_phy, theta_phy, wind_phy real(kind_phys), dimension(ims:ime, jms:jme), intent(out) :: & - u10, v10, ust, tsk, xland, xlat, xlong, dxy, vegfrac, rmol, swdown, znt, & - pbl, hfx, snowh, clayf, rdrag, sandf, ssm, uthr + u10, v10, ust, tsk, xland, xlat, xlong, dxy, rmol, swdown, znt, & + pbl, hfx, snowh, clayf, rdrag, sandf, ssm, uthr, hwp_local + real(kind_phys), dimension(ims:ime, nlcat, jms:jme), intent(out) :: vegfrac real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w - real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois - real(kind_phys), dimension(ims:ime), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr - real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc - !real(kind_phys), dimension(ims:ime, jms:jme, num_plume_data) :: plume + real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois,stemp + real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: frp_in, fire_end_hr, fire_hist, coef_bb_dc + real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: hwp_day_avg, peak_hr + real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc,ebb_smoke_in real(kind_phys), parameter :: conv_frp = 1.e+06_kind_phys ! FRP conversion factor, MW to W - real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) + real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) ! -- local variables - integer i,ip,j,k,kp,kk,kkp,nv,l,ll,n + integer i,ip,j,k,k1,kp,kk,kkp,nv,l,ll,n,nl + real(kind_phys) :: SFCWIND,WIND,DELWIND,DZ,wdgust,snoweq,THETA + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme) :: THETAV + real(kind_phys), dimension(ims:ime, jms:jme) :: windgustpot + real(kind_phys), dimension(ims:ime, jms:jme), intent(out) :: kpbl_thetav + real(kind_phys), parameter :: delta_theta4gust = 0.5 + real(kind=kind_phys),parameter :: p1000mb = 100000. ! -- initialize fire emissions - !plume = 0._kind_phys - plume_frp = 0._kind_phys ebu_in = 0._kind_phys - ebb_smoke_hr = 0._kind_phys + ebb_smoke_in = 0._kind_phys emis_anoc = 0._kind_phys - frp_hr = 0._kind_phys - frp_std_hr = 0._kind_phys + frp_in = 0._kind_phys + hwp_day_avg = 0._kind_phys + fire_end_hr = 0._kind_phys ! -- initialize output arrays isltyp = 0._kind_phys ivgtyp = 0._kind_phys rri = 0._kind_phys t_phy = 0._kind_phys + theta_phy = 0._kind_phys u_phy = 0._kind_phys v_phy = 0._kind_phys + wind_phy = 0._kind_phys p_phy = 0._kind_phys + pi_phy = 0._kind_phys rho_phy = 0._kind_phys dz8w = 0._kind_phys p8w = 0._kind_phys t8w = 0._kind_phys vvel = 0._kind_phys zmid = 0._kind_phys - exch_h = 0._kind_phys u10 = 0._kind_phys v10 = 0._kind_phys ust = 0._kind_phys @@ -610,7 +734,6 @@ subroutine rrfs_smoke_prep( & moist = 0._kind_phys chem = 0._kind_phys z_at_w = 0._kind_phys - rel_hum = 0._kind_phys do i=its,ite u10 (i,1)=u10m (i) @@ -631,17 +754,20 @@ subroutine rrfs_smoke_prep( & sandf(i,1)=dust12m_in(i,current_month,3) ssm (i,1)=dust12m_in(i,current_month,4) uthr (i,1)=dust12m_in(i,current_month,5) - ivgtyp (i,1)=vegtype(i) + ivgtyp (i,1)=vegtype_dom (i) isltyp (i,1)=soiltyp(i) - vegfrac(i,1)=sigmaf (i) + do nl = 1,nlcat + vegfrac(i,nl,1)=vegtype_frac (i,nl) + enddo + rmol (i,1)=recmol (i) enddo - rmol=0. do k=1,nsoil do j=jts,jte do i=its,ite smois(i,k,j)=smc(i,k) + stemp(i,k,j)=tslb(i,k) enddo enddo enddo @@ -679,38 +805,24 @@ subroutine rrfs_smoke_prep( & 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)/(con_rd*t_phy(i,k,j)*(1.+con_fv*spechum(i,kkp))) + pi_phy(i,k,j) = con_cp*(p_phy(i,k,j)/p1000mb)**(con_rd/con_cp) + theta_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j)*con_cp + wind_phy(i,k,j) = sqrt(u_phy(i,k,j)**2 + v_phy(i,k,j)**2) + ! from mp_thompson.F90 ; rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) + ! from mynnd + rho_phy(i,k,j)=p_phy(i,k,j)/(con_rd*t_phy(i,k,j)) !*(1.+con_fv*spechum(i,kkp))) rri(i,k,j)=1./rho_phy(i,k,j) vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. - 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(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(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) = min(0.95,spechum(i,kkp)) - rel_hum(i,k,j) = min(0.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)) + moist(i,k,j,1)=gq0(i,kkp,1) + moist(i,k,j,2)=gq0(i,kkp,2) + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. !-- zmid(i,k,j)=phl3d(i,kkp)/g enddo enddo enddo - ! -- the imported atmospheric heat diffusivity is only available up to kte-1 - do k=kts,kte-1 - do i=its,ite - exch_h(i,k,1)=exch(i,k) - enddo - enddo - do j=jts,jte do k=2,kte do i=its,ite @@ -728,24 +840,111 @@ subroutine rrfs_smoke_prep( & ! -- anthropogenic organic carbon do i=its,ite - emis_anoc(i) = emi_in(i,1) + emis_anoc(i) = emi_ant_in(i,1) enddo - if (hour_int<24) then - do j=jts,jte - do i=its,ite - 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 +!---- Calculate PBLH and K-PBL based on virtual potential temperature profile +!---- First calculate THETAV + do j = jts,jte + do i = its,ite + do k = kts,kte + THETA = t_phy(i,k,j) * (1.E5/p_phy(i,k,j))**0.286 + THETAV(i,k,j) = THETA * (1. + 0.61 * (moist(i,k,j,p_qv))) + enddo + enddo + enddo +!---- Now use the UPP code to deterimine the height and level + do i = its, ite + do j = jts, jte + if ( THETAV(i,kts+1,j) .lt. ( THETAV(i,kts,j) + delta_theta4gust) ) then + do k = kts+1, kte + k1 = k +!--- give theta-v at the sfc a 0.5K boost in the PBLH definition + if ( THETAV(i,kts+k-1,j) .gt. ( THETAV(i,kts,j) + delta_theta4gust) ) then + exit + endif + enddo + kpbl_thetav(i,j) = k1 + else + kpbl_thetav(i,j) = kts + 1 + endif + enddo + enddo + +!---- Calculate wind gust potential and HWP + do i = its,ite + SFCWIND = sqrt(u10m(i)**2+v10m(i)**2) + windgustpot(i,1) = SFCWIND + if (kpbl_thetav(i,1)+1 .ge. kts+1 ) then + do k=kts+1,int(kpbl_thetav(i,1))+1 + WIND = sqrt(us3d(i,k)**2+vs3d(i,k)**2) + DELWIND = WIND - SFCWIND + DZ = zmid(i,k,1) - oro(i) + DELWIND = DELWIND*(1.0-MIN(0.5,DZ/2000.)) + windgustpot(i,1) = max(windgustpot(i,1),SFCWIND+DELWIND) + enddo + endif + enddo + hwp_local = 0. + do i=its,ite + wdgust=max(windgustpot(i,1),3.) + snoweq=max((25.-snow_cpl(i))/25.,0.) + hwp_local(i,1)=0.177*wdgust**0.97*max(t2m(i)-dpt2m(i),15.)**1.03*((1.-wetness(i))**0.4)*snoweq ! Eric update 11/2023 + enddo +! Set paramters for ebb_dcycle option + if (ebb_dcycle == 1 ) then + if (hour_int .le. 24) then + do j=jts,jte + do i=its,ite + ebu_in (i,j) = smoke_RRFS(i,hour_int+1,1) ! smoke + frp_in (i,j) = smoke_RRFS(i,hour_int+1,2)*conv_frp ! frp + ! These 2 arrays aren't needed for this option + ! fire_end_hr(i,j) = 0.0 + ! hwp_day_avg(i,j) = 0.0 + ebb_smoke_in (i) = ebu_in(i,j) + enddo + enddo + endif endif + ! RAR: here we need to initialize various arrays in order to apply HWP to + ! diurnal cycle + ! if ebb_dcycle/=2 then those arrays=0, we need to read in temporal + if (ebb_dcycle == 2) then + do i=its, ite + do j=jts, jte + ebu_in (i,j) = smoke2d_RRFS(i,1)!/86400. + frp_in (i,j) = smoke2d_RRFS(i,2)*conv_frp + fire_end_hr (i,j) = smoke2d_RRFS(i,3) + hwp_day_avg (i,j) = smoke2d_RRFS(i,4) + ebb_smoke_in(i ) = ebu_in(i,j) + enddo + enddo + end if - ! We will add a namelist variable, real :: flam_frac_global + if (ktau==1) then + do j=jts,jte + do i=its,ite + ! GFS_typedefs.F90 initializes this = 1, but should be OK to duplicate, RAR?? + fire_hist (i,j) = 1. + coef_bb_dc (i,j) = 1. + if (xlong(i,j)<230.) then + peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska + elseif(xlong(i,j)<245.) then + peak_hr(i,j)= 23.0* 3600. + 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)<275.) then + peak_hr(i,j)= 21.0* 3600. + 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 + endif + ! We will add a namelist variable, real :: flam_frac_global, RAR?? do k=kms,kte do i=ims,ime chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )) @@ -754,9 +953,8 @@ subroutine rrfs_smoke_prep( & enddo enddo - - end subroutine rrfs_smoke_prep + !> @} end module rrfs_smoke_wrapper diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index cddc20fbc..271d2dd36 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -1,9 +1,198 @@ [ccpp-table-properties] name = rrfs_smoke_wrapper type = scheme - 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,coarsepm_settling_mod.F90 + dependencies = dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,coarsepm_settling_mod.F90, dep_dry_mod_emerson.F90,dep_data_mod.F90 ######################################################################## +[ccpp-arg-table] + name = rrfs_smoke_wrapper_init + type = scheme +[seas_opt_in] + standard_name = control_for_smoke_sea_salt + long_name = rrfs smoke sea salt emission 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 + units = index + dimensions = () + type = integer + intent = in +[pm_settling_in] + standard_name = control_for_smoke_pm_settling + long_name = rrfs smoke pm settling option + units = index + dimensions = () + type = integer + intent = in +[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 +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[add_fire_heat_flux_in] + standard_name = flag_for_fire_heat_flux + long_name = flag to add fire heat flux to LSM + units = flag + dimensions = () + type = logical + intent = in +[do_plumerise_in] + standard_name = do_smoke_plumerise + long_name = rrfs smoke plumerise option + units = index + dimensions = () + type = logical + intent = in +[plumerisefire_frq_in] + standard_name = smoke_plumerise_frequency + long_name = rrfs smoke add smoke option + units = min + dimensions = () + type = integer + intent = in +[n_dbg_lines_in] + standard_name = smoke_debug_lines + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[plume_wind_eff_in] + standard_name = option_for_wind_effects_on_smoke_plumerise + long_name = wind effect plumerise option + units = index + dimensions = () + type = integer + intent = in +[addsmoke_flag_in] + standard_name = control_for_smoke_biomass_burning_emissions + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in +[ebb_dcycle_in] + standard_name = control_for_diurnal_cycle_of_biomass_burning_emissions + long_name = rrfs smoke diurnal cycle option + units = index + dimensions = () + type = integer + intent = in +[smoke_forecast_in] + standard_name = do_smoke_forecast + long_name = index for rrfs smoke forecast + units = index + dimensions = () + type = integer + intent = in +[dust_opt_in] + standard_name = control_for_smoke_dust + long_name = rrfs smoke dust chem option + units = index + dimensions = () + type = integer + 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 +[dust_moist_opt_in] + standard_name = control_for_dust_soil_moisture_option + long_name = smoke dust moisture parameterization 1 - fecan 2 - shao + units = index + dimensions = () + type = integer + active = (do_smoke_coupling) + intent = in +[dust_moist_correction_in] + standard_name = dust_moist_correction_fengsha_dust_scheme + long_name = moisture correction term for fengsha dust emission + units = none + dimensions = () + type = real + kind = kind_phys + active = (do_smoke_coupling) + intent = in +[dust_drylimit_factor_in] + standard_name = dust_drylimit_factor_fengsha_dust_scheme + long_name = moisture correction term for drylimit in fengsha dust emission + units = none + dimensions = () + type = real + kind = kind_phys + active = (do_smoke_coupling) + intent = in +[aero_ind_fdb_in] + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for rrfs wfa ifa emission + units = flag + dimensions = () + type = logical + intent = in +[extended_sd_diags_in] + standard_name = flag_for_extended_smoke_dust_diagnostics + long_name = flag for extended smoke dust diagnostics + units = flag + dimensions = () + type = logical + intent = in +[dbg_opt_in] + standard_name = do_smoke_debug + long_name = flag for rrfs smoke plumerise debug + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +##################################################################### [ccpp-arg-table] name = rrfs_smoke_wrapper_run type = scheme @@ -224,7 +413,15 @@ type = real kind = kind_phys intent = inout -[vegtype] +[tslb] + standard_name = soil_temperature_for_land_surface_model + long_name = soil temperature for land surface model + units = K + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil_internal_to_land_surface_scheme) + type = real + kind = kind_phys + intent = in +[vegtype_dom] standard_name = vegetation_type_classification long_name = vegetation type at each grid cell units = index @@ -238,11 +435,18 @@ dimensions = (horizontal_loop_extent) type = integer intent = in -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom +[nlcat] + standard_name = number_of_vegetation_categories + long_name = number of vegetation categories + units = count + dimensions = () + type = integer + intent = in +[vegtype_frac] + standard_name = fraction_of_vegetation_category + long_name = fraction of horizontal grid area occupied by given vegetation category units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_loop_extent,number_of_vegetation_categories) type = real kind = kind_phys intent = in @@ -278,6 +482,14 @@ type = real kind = kind_phys intent = in +[recmol] + standard_name = reciprocal_of_obukhov_length + long_name = one over obukhov length + units = m-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [idat] standard_name = date_and_time_at_model_initialization_in_iso_order long_name = initialization date and time @@ -301,14 +513,6 @@ type = real kind = kind_phys intent = in -[exch] - standard_name = atmosphere_heat_diffusivity - long_name = diffusivity for heat - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [hf2d] standard_name = instantaneous_surface_upward_sensible_heat_flux long_name = surface upward sensible heat flux valid for current call @@ -365,7 +569,7 @@ type = real kind = kind_phys intent = in -[emi_in] +[emi_ant_in] standard_name = anthropogenic_background_input long_name = anthropogenic background input units = various @@ -377,7 +581,15 @@ standard_name = emission_smoke_RRFS long_name = emission fire RRFS units = various - dimensions = (horizontal_loop_extent,24,3) + dimensions = (horizontal_loop_extent,24,2) + type = real + kind = kind_phys + intent = in +[smoke2d_RRFS] + standard_name = emission_smoke_prvd_RRFS + long_name = emission fire RRFS daily + units = various + dimensions = (horizontal_loop_extent,4) type = real kind = kind_phys intent = in @@ -494,7 +706,7 @@ type = real kind = kind_phys intent = inout -[ebb_smoke_hr] +[ebb_smoke_in] standard_name = surface_smoke_emission long_name = emission of surface smoke units = ug m-2 s-1 @@ -502,7 +714,7 @@ type = real kind = kind_phys intent = inout -[frp_hr] +[frp_output] standard_name = frp_hourly long_name = hourly fire radiative power units = MW @@ -510,14 +722,6 @@ type = real kind = kind_phys intent = inout -[frp_std_hr] - standard_name = frp_std_hourly - long_name = hourly stdandard deviation of fire radiative power - units = MW - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout [coef_bb] standard_name = coef_bb_dc long_name = coef to estimate the fire emission @@ -526,6 +730,13 @@ type = real kind = kind_phys intent = inout +[fire_type_out] + standard_name = fire_type + long_name = type of fire + units = 1 + dimensions = (horizontal_loop_extent) + type = integer + intent = out [ebu_smoke] standard_name = ebu_smoke long_name = buffer of vertical fire emission @@ -558,6 +769,59 @@ type = real kind = kind_phys intent = inout +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[uspdavg] + standard_name = mean_wind_speed_in_boundary_layer + long_name = average wind speed within the boundary layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hpbl_thetav] + standard_name = atmosphere_boundary_layer_thickness_from_modified_parcel + long_name = pbl height based on modified parcel method + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[drydep_flux_out] + standard_name = dry_deposition_flux + long_name = rrfs dry deposition flux + units = ug m-2 + dimensions = (horizontal_loop_extent,number_of_chemical_species_deposited) + type = real + kind = kind_phys + intent = inout +[wetdpr] + standard_name = mp_wet_deposition_smoke_dust + long_name = large scale wet deposition of smoke and dust + units = kg kg-1 + dimensions = (horizontal_loop_extent,number_of_chemical_species_vertically_mixed) + type = real + kind = kind_phys + intent = inout [hwp] standard_name = hourly_wildfire_potential long_name = rrfs hourly fire weather potential @@ -566,6 +830,14 @@ type = real kind = kind_phys intent = out +[hwp_ave] + standard_name = hourly_wildfire_potential_average + long_name = rrfs hourly fire weather potential average + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [wetness] standard_name = normalized_soil_wetness_for_land_surface_model long_name = normalized soil wetness @@ -574,22 +846,6 @@ 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 - units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[dust_ext] - standard_name = extinction_coefficient_in_air_due_to_dust - long_name = extinction coefficient in air due to dust - units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out [ndvel] standard_name = number_of_chemical_species_deposited long_name = number of chemical pbl deposited @@ -605,148 +861,61 @@ 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_moist_opt_in] - standard_name = control_for_dust_soil_moisture_option - long_name = smoke dust moisture parameterization 1 - fecan 2 - shao - units = index - dimensions = () - type = integer - active = (do_smoke_coupling) - intent = in -[dust_moist_correction_in] - standard_name = dust_moist_correction_fengsha_dust_scheme - long_name = moisture correction term for fengsha dust emission - units = none - dimensions = () - type = real - kind = kind_phys - active = (do_smoke_coupling) - intent = in -[dust_drylimit_factor_in] - standard_name = dust_drylimit_factor_fengsha_dust_scheme - long_name = moisture correction term for drylimit in fengsha dust emission - units = none - dimensions = () - type = real - kind = kind_phys - active = (do_smoke_coupling) - 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 = () +[peak_hr_out] + standard_name = peak_hr_fire + long_name = time_of_peak_fire_emissions + units = s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[lu_nofire_out] + standard_name = sum_of_land_use_fractions_for_no_fire_pixels + long_name = land use of no fire pixels for type + units = 1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[lu_qfire_out] + standard_name = sum_of_land_use_fractions_for_cropland_fire_pixels + long_name = land use of fire pixels for type + units = 1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[fire_heat_flux_out] + standard_name = surface_fire_heat_flux + long_name = heat flux of fire at the surface + units = W m-2 + dimensions = (horizontal_loop_extent) 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) + intent = out +[frac_grid_burned_out] + standard_name = fraction_of_grid_cell_burning + long_name = ration of the burnt area to the grid cell area + units = frac + dimensions = (horizontal_loop_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 - units = index - dimensions = () - type = integer - intent = in -[dust_opt_in] - standard_name = control_for_smoke_dust - long_name = rrfs smoke dust chem 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 - units = index - dimensions = () - type = integer - intent = in -[coarsepm_settling_in] - standard_name = control_for_smoke_coarsepm_settling - long_name = rrfs smoke coarsepm settling option - units = index - dimensions = () - type = integer - intent = in -[wetdep_ls_opt_in] - standard_name = control_for_smoke_wet_deposition - long_name = rrfs smoke large scale wet deposition option + intent = out +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = PBL top model level index units = index - dimensions = () + dimensions = (horizontal_loop_extent) 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 = () +[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 -[do_plumerise_in] - standard_name = do_smoke_plumerise - long_name = rrfs smoke plumerise option - units = index - dimensions = () - type = logical - intent = in -[plumerisefire_frq_in] - standard_name = smoke_plumerise_frequency - long_name = rrfs smoke add smoke option - units = min - dimensions = () - type = integer - intent = in -[addsmoke_flag_in] - standard_name = control_for_smoke_biomass_burning_emissions - long_name = rrfs smoke add smoke option - units = index - dimensions = () - type = integer - intent = in -[smoke_forecast_in] - standard_name = do_smoke_forecast - long_name = index for rrfs smoke forecast - units = index - dimensions = () - type = integer - intent = in -[aero_ind_fdb_in] - standard_name = do_smoke_aerosol_indirect_feedback - long_name = flag for rrfs wfa ifa emission - units = flag - dimensions = () - type = logical - intent = in -[dbg_opt_in] - standard_name = do_smoke_debug - long_name = flag for rrfs smoke plumerise debug - units = flag - dimensions = () - type = logical - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/smoke_dust/seas_mod.F90 b/physics/smoke_dust/seas_mod.F90 index 1d18046ad..e5e63e909 100755 --- a/physics/smoke_dust/seas_mod.F90 +++ b/physics/smoke_dust/seas_mod.F90 @@ -185,7 +185,6 @@ subroutine gocart_seasalt_driver(dt,alt,t_phy,u_phy, & chem(i,kts,j,p_seas_3) = chem(i,kts,j,p_seas_3) + tc(3)*converi chem(i,kts,j,p_seas_4) = chem(i,kts,j,p_seas_4) + tc(4)*converi chem(i,kts,j,p_seas_5) = chem(i,kts,j,p_seas_5) + tc(5)*converi - !print*,'hli tc(2),chem(i,kts,j,p_seas_2)',tc(2),chem(i,kts,j,p_seas_2) ! for output diagnostics emis_seas(i,1,j,p_eseas1) = bems(1) diff --git a/physics/funcphys.f90 b/physics/tools/funcphys.f90 similarity index 100% rename from physics/funcphys.f90 rename to physics/tools/funcphys.f90 diff --git a/physics/get_phi_fv3.F90 b/physics/tools/get_phi_fv3.F90 similarity index 100% rename from physics/get_phi_fv3.F90 rename to physics/tools/get_phi_fv3.F90 diff --git a/physics/get_phi_fv3.meta b/physics/tools/get_phi_fv3.meta similarity index 97% rename from physics/get_phi_fv3.meta rename to physics/tools/get_phi_fv3.meta index cbca14080..5c162c746 100644 --- a/physics/get_phi_fv3.meta +++ b/physics/tools/get_phi_fv3.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = get_phi_fv3 type = scheme - dependencies = machine.F,physcons.F90 + dependencies = ../hooks/machine.F,../hooks/physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/get_prs_fv3.F90 b/physics/tools/get_prs_fv3.F90 similarity index 100% rename from physics/get_prs_fv3.F90 rename to physics/tools/get_prs_fv3.F90 diff --git a/physics/get_prs_fv3.meta b/physics/tools/get_prs_fv3.meta similarity index 98% rename from physics/get_prs_fv3.meta rename to physics/tools/get_prs_fv3.meta index c26f5c308..4cdad7566 100644 --- a/physics/get_prs_fv3.meta +++ b/physics/tools/get_prs_fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = get_prs_fv3 type = scheme - dependencies = machine.F + dependencies = ../hooks/machine.F ######################################################################## [ccpp-arg-table] diff --git a/tools/check_encoding.py b/tools/check_encoding.py index 1d24d4679..d964ebaab 100755 --- a/tools/check_encoding.py +++ b/tools/check_encoding.py @@ -15,11 +15,7 @@ if suffix in SUFFICES: with open(os.path.join(root, file)) as f: contents = f.read() - try: - contents.decode('ascii') - except UnicodeDecodeError: + if not contents.isascii(): for line in contents.split('\n'): - try: - line.decode('ascii') - except UnicodeDecodeError: + if not line.isascii(): raise Exception('Detected non-ascii characters in file {}, line: "{}"'.format(os.path.join(root, file), line))